mirror of https://gitlab.com/QEF/q-e.git
175 lines
5.6 KiB
Fortran
175 lines
5.6 KiB
Fortran
!
|
|
! Copyright (C) 2015-2016 Satomichi Nishihara
|
|
!
|
|
! This file is distributed under the terms of the
|
|
! GNU General Public License. See the file `License'
|
|
! in the root directory of the present distribution,
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
MODULE err_rism
|
|
!--------------------------------------------------------------------------
|
|
!
|
|
USE mp, ONLY : mp_size, mp_rank, mp_gather, mp_bcast
|
|
!
|
|
! ... this module defines error code used in RISM.
|
|
!
|
|
IMPLICIT NONE
|
|
SAVE
|
|
PRIVATE
|
|
!
|
|
! not error
|
|
INTEGER, PARAMETER :: IERR_RISM_NULL = 0
|
|
! incorrect data type
|
|
INTEGER, PARAMETER :: IERR_RISM_INCORRECT_DATA_TYPE = 1
|
|
! 1D-RISM data is not available
|
|
INTEGER, PARAMETER :: IERR_RISM_1DRISM_IS_NOT_AVAIL = 2
|
|
! 1D-, 3D-RISM iteration is not converged
|
|
INTEGER, PARAMETER :: IERR_RISM_NOT_CONVERGED = 3
|
|
! Lennard-Jones parameters are unsupported
|
|
INTEGER, PARAMETER :: IERR_RISM_LJ_UNSUPPORTED = 4
|
|
! Lennard-Jones parameters are out of range
|
|
INTEGER, PARAMETER :: IERR_RISM_LJ_OUT_OF_RANGE = 5
|
|
! cannot solve dgetrf (in LAPACK)
|
|
INTEGER, PARAMETER :: IERR_RISM_CANNOT_DGETRF = 6
|
|
! cannot solve dgetrs (in LAPACK)
|
|
INTEGER, PARAMETER :: IERR_RISM_CANNOT_DGETRS = 7
|
|
! charge of solvent is not zero (in Laue-RISM)
|
|
INTEGER, PARAMETER :: IERR_RISM_NONZERO_CHARGE = 8
|
|
! solvent does not have any ions (in Laue-RISM)
|
|
INTEGER, PARAMETER :: IERR_RISM_NOT_ANY_IONS = 9
|
|
! fail to make potential smooth (in Laue-RISM)
|
|
INTEGER, PARAMETER :: IERR_RISM_FAIL_SMOOTH = 10
|
|
! too large box of Laue-FFT (in Laue-RISM)
|
|
INTEGER, PARAMETER :: IERR_RISM_LARGE_LAUE_BOX = 11
|
|
!
|
|
! ... public components
|
|
PUBLIC :: stop_by_err_rism
|
|
PUBLIC :: merge_ierr_rism
|
|
PUBLIC :: IERR_RISM_NULL
|
|
PUBLIC :: IERR_RISM_INCORRECT_DATA_TYPE
|
|
PUBLIC :: IERR_RISM_1DRISM_IS_NOT_AVAIL
|
|
PUBLIC :: IERR_RISM_NOT_CONVERGED
|
|
PUBLIC :: IERR_RISM_LJ_UNSUPPORTED
|
|
PUBLIC :: IERR_RISM_LJ_OUT_OF_RANGE
|
|
PUBLIC :: IERR_RISM_CANNOT_DGETRF
|
|
PUBLIC :: IERR_RISM_CANNOT_DGETRS
|
|
PUBLIC :: IERR_RISM_NONZERO_CHARGE
|
|
PUBLIC :: IERR_RISM_NOT_ANY_IONS
|
|
PUBLIC :: IERR_RISM_FAIL_SMOOTH
|
|
PUBLIC :: IERR_RISM_LARGE_LAUE_BOX
|
|
!
|
|
CONTAINS
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
SUBROUTINE stop_by_err_rism(parent, ierr, stat)
|
|
!--------------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
CHARACTER(LEN=*), INTENT(IN) :: parent
|
|
INTEGER, INTENT(IN) :: ierr
|
|
INTEGER, OPTIONAL, INTENT(IN) :: stat
|
|
!
|
|
INTEGER :: stat_
|
|
!
|
|
IF (PRESENT(stat)) THEN
|
|
stat_ = stat
|
|
ELSE
|
|
stat_ = 0
|
|
END IF
|
|
!
|
|
IF (stat_ == 0) THEN
|
|
stat_ = ierr
|
|
END IF
|
|
!
|
|
stat_ = MAX(ABS(stat_), 1)
|
|
!
|
|
SELECT CASE (ierr)
|
|
CASE (IERR_RISM_INCORRECT_DATA_TYPE)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, incorrect data type ', stat_)
|
|
!
|
|
CASE (IERR_RISM_1DRISM_IS_NOT_AVAIL)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, data of 1D is not available ', stat_)
|
|
!
|
|
CASE (IERR_RISM_NOT_CONVERGED)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, iteration has not been converged ', stat_)
|
|
!
|
|
CASE (IERR_RISM_LJ_UNSUPPORTED)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, specified L.J.-parameters are not supported ', stat_)
|
|
!
|
|
CASE (IERR_RISM_LJ_OUT_OF_RANGE)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, specified L.J.-parameters are out of range ', stat_)
|
|
!
|
|
CASE (IERR_RISM_CANNOT_DGETRF)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, error at lapack::dgetrf ', stat_)
|
|
!
|
|
CASE (IERR_RISM_CANNOT_DGETRS)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, error at lapack::dgetrs ', stat_)
|
|
!
|
|
CASE (IERR_RISM_NONZERO_CHARGE)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, charge of solvent is not zero ', stat_)
|
|
!
|
|
CASE (IERR_RISM_NOT_ANY_IONS)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, solvent does not have any ions ', stat_)
|
|
!
|
|
CASE (IERR_RISM_FAIL_SMOOTH)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, fail to make potential smooth ', stat_)
|
|
!
|
|
CASE (IERR_RISM_LARGE_LAUE_BOX)
|
|
CALL errore(' ' // TRIM(ADJUSTL(parent)) // ' ', &
|
|
& ' in RISM, too large box of Laue-FFT than 1D-FFT ', stat_)
|
|
!
|
|
END SELECT
|
|
!
|
|
END SUBROUTINE stop_by_err_rism
|
|
!
|
|
!--------------------------------------------------------------------------
|
|
SUBROUTINE merge_ierr_rism(ierr, comm)
|
|
!--------------------------------------------------------------------------
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(INOUT) :: ierr
|
|
INTEGER, INTENT(IN) :: comm
|
|
!
|
|
INTEGER :: nproc
|
|
INTEGER :: iproc
|
|
INTEGER :: irank
|
|
INTEGER, ALLOCATABLE :: iallerr(:)
|
|
!
|
|
nproc = mp_size(comm)
|
|
irank = mp_rank(comm)
|
|
ALLOCATE(iallerr(nproc))
|
|
!
|
|
CALL mp_gather(ierr, iallerr, 0, comm)
|
|
!
|
|
IF (irank == 0) THEN
|
|
ierr = IERR_RISM_NULL
|
|
DO iproc = 1, nproc
|
|
IF (iallerr(iproc) /= IERR_RISM_NULL) THEN
|
|
ierr = iallerr(iproc)
|
|
EXIT
|
|
END IF
|
|
END DO
|
|
END IF
|
|
!
|
|
CALL mp_bcast(ierr, 0, comm)
|
|
!
|
|
DEALLOCATE(iallerr)
|
|
!
|
|
END SUBROUTINE merge_ierr_rism
|
|
!
|
|
END MODULE err_rism
|
|
|