comp-chem/cp2k
1
0
Fork 0
mirror of https://github.com/cp2k/cp2k.git synced 2026-07-28 22:25:32 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions

prettied cp_* pao_*

Browse source 
svn-origin-rev: 993
This commit is contained in:
Mohamed Fawzi 2002-11-22 11:28:21 +00:00
parent 016ff5bc12
commit 3bd4f05710
36 changed files with 5534 additions and 5212 deletions
Download patch file Download diff file Expand all files Collapse all files

57
src/cp_array_i_utils.F
View file

@ -27,17 +27,28 @@
!! SOURCE
!****************************************************************************
MODULE cp_array_i_utils
USE kinds, ONLY: wp=>dp
USE cp_log_handling, ONLY: cp_to_string, cp_failure_level, cp_warning_level,&
cp_note_level, cp_log, cp_logger_type, cp_logger_generate_filename
USE cp_error_handling, ONLY: cp_debug, cp_error_type, cp_assert, &
cp_error_message,cp_assertion_failed, cp_internal_error,&
cp_error_init, cp_error_dealloc_ref
USE global_types, ONLY: global_environment_type
USE timings, ONLY: timeset, timestop
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_log,&
cp_logger_generate_filename,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_output_handling
USE qs_parser, ONLY: open_file, close_file
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE qs_parser, ONLY: close_file,&
open_file
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
@ -103,7 +114,7 @@ CONTAINS
!!
!!*** **********************************************************************
SUBROUTINE cp_i_write(element, unit_nr, el_format, error)
integer, INTENT(in) :: element
INTEGER, INTENT(in) :: element
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -184,7 +195,7 @@ SUBROUTINE cp_1d_i_output(logger, outputName,&
CHARACTER(len=*) , INTENT(in) :: outputName
CHARACTER(len=*), INTENT(in):: fromWhere
INTEGER, INTENT(in) :: iter
integer, INTENT(in), DIMENSION(:) :: array
INTEGER, INTENT(in), DIMENSION(:) :: array
CHARACTER(len=*), INTENT(in),OPTIONAL :: comment, el_format
LOGICAL, INTENT(in), OPTIONAL :: local
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -212,7 +223,7 @@ SUBROUTINE cp_1d_i_output(logger, outputName,&
fromWhere=routineP,message=" overwriting file '"//filename//"'",&
error=error)
CALL open_file(TRIM(filename),file_status="unknown",&
file_action="write",&
file_action="WRITE",&
unit_number=unitNr)
IF (PRESENT(comment)) THEN
@ -265,7 +276,7 @@ END SUBROUTINE cp_1d_i_output
!!
!!*** **********************************************************************
SUBROUTINE cp_1d_i_write(array, unit_nr, el_format, error)
integer, DIMENSION(:), INTENT(in) :: array
INTEGER, DIMENSION(:), INTENT(in) :: array
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -349,7 +360,7 @@ SUBROUTINE cp_2d_i_output(logger, outputName, &
CHARACTER(len=*) , INTENT(in) :: outputName
CHARACTER(len=*), INTENT(in):: fromWhere
INTEGER, INTENT(in) :: iter
integer, INTENT(in), DIMENSION(:,:) :: array
INTEGER, INTENT(in), DIMENSION(:,:) :: array
CHARACTER(len=*), INTENT(in),OPTIONAL :: comment, el_format
LOGICAL, INTENT(in), OPTIONAL :: local
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -377,7 +388,7 @@ SUBROUTINE cp_2d_i_output(logger, outputName, &
fromWhere=routineP,message=" overwriting file '"//filename//"'",&
error=error)
CALL open_file(TRIM(filename),file_status="unknown",&
file_action="write",&
file_action="WRITE",&
unit_number=unitNr)
IF (PRESENT(comment)) THEN
@ -430,7 +441,7 @@ END SUBROUTINE cp_2d_i_output
!!
!!*** **********************************************************************
SUBROUTINE cp_2d_i_write(array, unit_nr, el_format, error)
integer, DIMENSION(:,:), INTENT(in) :: array
INTEGER, DIMENSION(:,:), INTENT(in) :: array
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -499,9 +510,9 @@ END SUBROUTINE cp_2d_i_write
!!
!!*** **********************************************************************
SUBROUTINE cp_1d_i_guarantee_size(array, n, init, error)
integer, DIMENSION(:), POINTER :: array
INTEGER, DIMENSION(:), POINTER :: array
INTEGER, INTENT(in) :: n
integer, INTENT(in), OPTIONAL :: init
INTEGER, INTENT(in), OPTIONAL :: init
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
LOGICAL :: failure
@ -571,9 +582,9 @@ END SUBROUTINE cp_2d_i_write
!!*** **********************************************************************
SUBROUTINE cp_2d_i_guarantee_size(array, n_rows, n_cols ,&
init, error)
integer, DIMENSION(:,:), POINTER :: array
INTEGER, DIMENSION(:,:), POINTER :: array
INTEGER, INTENT(in) :: n_rows, n_cols
integer, INTENT(in), OPTIONAL :: init
INTEGER, INTENT(in), OPTIONAL :: init
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
LOGICAL :: failure
@ -606,10 +617,10 @@ END SUBROUTINE cp_2d_i_write
! files are almost the same (multi-line use change it a bit)
! [template(type1,nametype1,USE,defaultFormatType1)]
! ARGS:
! type1 = "integer"
! nametype1 = "i"
! USE = ""
! defaultFormatType1 = ""(i6)""
! nametype1 = "i"
! type1 = "integer"
END MODULE cp_array_i_utils

57
src/cp_array_logical_utils.F
View file

@ -27,17 +27,28 @@
!! SOURCE
!****************************************************************************
MODULE cp_array_logical_utils
USE kinds, ONLY: wp=>dp
USE cp_log_handling, ONLY: cp_to_string, cp_failure_level, cp_warning_level,&
cp_note_level, cp_log, cp_logger_type, cp_logger_generate_filename
USE cp_error_handling, ONLY: cp_debug, cp_error_type, cp_assert, &
cp_error_message,cp_assertion_failed, cp_internal_error,&
cp_error_init, cp_error_dealloc_ref
USE global_types, ONLY: global_environment_type
USE timings, ONLY: timeset, timestop
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_log,&
cp_logger_generate_filename,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_output_handling
USE qs_parser, ONLY: open_file, close_file
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE qs_parser, ONLY: close_file,&
open_file
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
@ -103,7 +114,7 @@ CONTAINS
!!
!!*** **********************************************************************
SUBROUTINE cp_logical_write(element, unit_nr, el_format, error)
logical, INTENT(in) :: element
LOGICAL, INTENT(in) :: element
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -184,7 +195,7 @@ SUBROUTINE cp_1d_logical_output(logger, outputName,&
CHARACTER(len=*) , INTENT(in) :: outputName
CHARACTER(len=*), INTENT(in):: fromWhere
INTEGER, INTENT(in) :: iter
logical, INTENT(in), DIMENSION(:) :: array
LOGICAL, INTENT(in), DIMENSION(:) :: array
CHARACTER(len=*), INTENT(in),OPTIONAL :: comment, el_format
LOGICAL, INTENT(in), OPTIONAL :: local
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -212,7 +223,7 @@ SUBROUTINE cp_1d_logical_output(logger, outputName,&
fromWhere=routineP,message=" overwriting file '"//filename//"'",&
error=error)
CALL open_file(TRIM(filename),file_status="unknown",&
file_action="write",&
file_action="WRITE",&
unit_number=unitNr)
IF (PRESENT(comment)) THEN
@ -265,7 +276,7 @@ END SUBROUTINE cp_1d_logical_output
!!
!!*** **********************************************************************
SUBROUTINE cp_1d_logical_write(array, unit_nr, el_format, error)
logical, DIMENSION(:), INTENT(in) :: array
LOGICAL, DIMENSION(:), INTENT(in) :: array
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -349,7 +360,7 @@ SUBROUTINE cp_2d_logical_output(logger, outputName, &
CHARACTER(len=*) , INTENT(in) :: outputName
CHARACTER(len=*), INTENT(in):: fromWhere
INTEGER, INTENT(in) :: iter
logical, INTENT(in), DIMENSION(:,:) :: array
LOGICAL, INTENT(in), DIMENSION(:,:) :: array
CHARACTER(len=*), INTENT(in),OPTIONAL :: comment, el_format
LOGICAL, INTENT(in), OPTIONAL :: local
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -377,7 +388,7 @@ SUBROUTINE cp_2d_logical_output(logger, outputName, &
fromWhere=routineP,message=" overwriting file '"//filename//"'",&
error=error)
CALL open_file(TRIM(filename),file_status="unknown",&
file_action="write",&
file_action="WRITE",&
unit_number=unitNr)
IF (PRESENT(comment)) THEN
@ -430,7 +441,7 @@ END SUBROUTINE cp_2d_logical_output
!!
!!*** **********************************************************************
SUBROUTINE cp_2d_logical_write(array, unit_nr, el_format, error)
logical, DIMENSION(:,:), INTENT(in) :: array
LOGICAL, DIMENSION(:,:), INTENT(in) :: array
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -499,9 +510,9 @@ END SUBROUTINE cp_2d_logical_write
!!
!!*** **********************************************************************
SUBROUTINE cp_1d_logical_guarantee_size(array, n, init, error)
logical, DIMENSION(:), POINTER :: array
LOGICAL, DIMENSION(:), POINTER :: array
INTEGER, INTENT(in) :: n
logical, INTENT(in), OPTIONAL :: init
LOGICAL, INTENT(in), OPTIONAL :: init
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
LOGICAL :: failure
@ -571,9 +582,9 @@ END SUBROUTINE cp_2d_logical_write
!!*** **********************************************************************
SUBROUTINE cp_2d_logical_guarantee_size(array, n_rows, n_cols ,&
init, error)
logical, DIMENSION(:,:), POINTER :: array
LOGICAL, DIMENSION(:,:), POINTER :: array
INTEGER, INTENT(in) :: n_rows, n_cols
logical, INTENT(in), OPTIONAL :: init
LOGICAL, INTENT(in), OPTIONAL :: init
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
LOGICAL :: failure
@ -606,10 +617,10 @@ END SUBROUTINE cp_2d_logical_write
! files are almost the same (multi-line use change it a bit)
! [template(type1,nametype1,USE,defaultFormatType1)]
! ARGS:
! type1 = "logical"
! nametype1 = "logical"
! USE = ""
! defaultFormatType1 = ""(t1)""
! nametype1 = "logical"
! type1 = "logical"
END MODULE cp_array_logical_utils

57
src/cp_array_r_utils.F
View file

@ -27,17 +27,28 @@
!! SOURCE
!****************************************************************************
MODULE cp_array_r_utils
USE kinds, ONLY: wp=>dp
USE cp_log_handling, ONLY: cp_to_string, cp_failure_level, cp_warning_level,&
cp_note_level, cp_log, cp_logger_type, cp_logger_generate_filename
USE cp_error_handling, ONLY: cp_debug, cp_error_type, cp_assert, &
cp_error_message,cp_assertion_failed, cp_internal_error,&
cp_error_init, cp_error_dealloc_ref
USE global_types, ONLY: global_environment_type
USE timings, ONLY: timeset, timestop
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_log,&
cp_logger_generate_filename,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_output_handling
USE qs_parser, ONLY: open_file, close_file
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE qs_parser, ONLY: close_file,&
open_file
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
@ -103,7 +114,7 @@ CONTAINS
!!
!!*** **********************************************************************
SUBROUTINE cp_r_write(element, unit_nr, el_format, error)
real(kind=wp), INTENT(in) :: element
REAL(kind=wp), INTENT(in) :: element
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -184,7 +195,7 @@ SUBROUTINE cp_1d_r_output(logger, outputName,&
CHARACTER(len=*) , INTENT(in) :: outputName
CHARACTER(len=*), INTENT(in):: fromWhere
INTEGER, INTENT(in) :: iter
real(kind=wp), INTENT(in), DIMENSION(:) :: array
REAL(kind=wp), INTENT(in), DIMENSION(:) :: array
CHARACTER(len=*), INTENT(in),OPTIONAL :: comment, el_format
LOGICAL, INTENT(in), OPTIONAL :: local
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -212,7 +223,7 @@ SUBROUTINE cp_1d_r_output(logger, outputName,&
fromWhere=routineP,message=" overwriting file '"//filename//"'",&
error=error)
CALL open_file(TRIM(filename),file_status="unknown",&
file_action="write",&
file_action="WRITE",&
unit_number=unitNr)
IF (PRESENT(comment)) THEN
@ -265,7 +276,7 @@ END SUBROUTINE cp_1d_r_output
!!
!!*** **********************************************************************
SUBROUTINE cp_1d_r_write(array, unit_nr, el_format, error)
real(kind=wp), DIMENSION(:), INTENT(in) :: array
REAL(kind=wp), DIMENSION(:), INTENT(in) :: array
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -349,7 +360,7 @@ SUBROUTINE cp_2d_r_output(logger, outputName, &
CHARACTER(len=*) , INTENT(in) :: outputName
CHARACTER(len=*), INTENT(in):: fromWhere
INTEGER, INTENT(in) :: iter
real(kind=wp), INTENT(in), DIMENSION(:,:) :: array
REAL(kind=wp), INTENT(in), DIMENSION(:,:) :: array
CHARACTER(len=*), INTENT(in),OPTIONAL :: comment, el_format
LOGICAL, INTENT(in), OPTIONAL :: local
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -377,7 +388,7 @@ SUBROUTINE cp_2d_r_output(logger, outputName, &
fromWhere=routineP,message=" overwriting file '"//filename//"'",&
error=error)
CALL open_file(TRIM(filename),file_status="unknown",&
file_action="write",&
file_action="WRITE",&
unit_number=unitNr)
IF (PRESENT(comment)) THEN
@ -430,7 +441,7 @@ END SUBROUTINE cp_2d_r_output
!!
!!*** **********************************************************************
SUBROUTINE cp_2d_r_write(array, unit_nr, el_format, error)
real(kind=wp), DIMENSION(:,:), INTENT(in) :: array
REAL(kind=wp), DIMENSION(:,:), INTENT(in) :: array
INTEGER, INTENT(in) :: unit_nr
CHARACTER(len=*), INTENT(in), OPTIONAL :: el_format
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -499,9 +510,9 @@ END SUBROUTINE cp_2d_r_write
!!
!!*** **********************************************************************
SUBROUTINE cp_1d_r_guarantee_size(array, n, init, error)
real(kind=wp), DIMENSION(:), POINTER :: array
REAL(kind=wp), DIMENSION(:), POINTER :: array
INTEGER, INTENT(in) :: n
real(kind=wp), INTENT(in), OPTIONAL :: init
REAL(kind=wp), INTENT(in), OPTIONAL :: init
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
LOGICAL :: failure
@ -571,9 +582,9 @@ END SUBROUTINE cp_2d_r_write
!!*** **********************************************************************
SUBROUTINE cp_2d_r_guarantee_size(array, n_rows, n_cols ,&
init, error)
real(kind=wp), DIMENSION(:,:), POINTER :: array
REAL(kind=wp), DIMENSION(:,:), POINTER :: array
INTEGER, INTENT(in) :: n_rows, n_cols
real(kind=wp), INTENT(in), OPTIONAL :: init
REAL(kind=wp), INTENT(in), OPTIONAL :: init
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
LOGICAL :: failure
@ -606,10 +617,10 @@ END SUBROUTINE cp_2d_r_write
! files are almost the same (multi-line use change it a bit)
! [template(type1,nametype1,USE,defaultFormatType1)]
! ARGS:
! type1 = "real(kind=wp)"
! nametype1 = "r"
! USE = ""
! defaultFormatType1 = ""(es14.6)""
! nametype1 = "r"
! type1 = "real(kind=wp)"
END MODULE cp_array_r_utils

11
src/cp_array_utils.F
View file

@ -23,11 +23,10 @@
!!
!! SOURCE
!****************************************************************************
module cp_array_utils
use cp_array_logical_utils
use cp_array_r_utils
use cp_array_i_utils
MODULE cp_array_utils
!!***
!****************************************************************************
end module cp_array_utils
USE cp_array_i_utils
USE cp_array_logical_utils
USE cp_array_r_utils
END MODULE cp_array_utils

1103
src/cp_b_matrix_structure.F
View file

File diff suppressed because it is too large Load diff

235
src/cp_blacs_env.F
View file

@ -24,39 +24,50 @@
!!
!! SOURCE
!****************************************************************************
module cp_blacs_env
use cp_log_handling, only: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log,&
cp_logger_type
use cp_error_handling, only: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
use kinds, only: int_size,&
wp => dp,&
wp_size => dp_size
use cp_para_types, only: cp_blacs_env_type
USE message_passing, ONLY: mp_bcast,&
mp_max,&
mp_sum,&
mp_sync
USE termination, ONLY: stop_memory,&
stop_program
use timings, only: timeset, timestop
USE global_types, ONLY: global_environment_type
implicit none
private
MODULE cp_blacs_env
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_para_types, ONLY: cp_blacs_env_type
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: int_size,&
wp => dp,&
wp_size => dp_size
USE message_passing, ONLY: mp_bcast,&
mp_max,&
mp_sum,&
mp_sync
USE termination, ONLY: stop_memory,&
stop_program
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character(len=*), private, parameter :: moduleN='cp_blacs_env'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='cp_blacs_env'
public :: cp_blacs_env_type ! make it accessible only through cp_para_types?
public :: cp_blacs_env_create, cp_blacs_env_retain, cp_blacs_env_release
public :: start_blacs, end_blacs, cp_blacs_env_write,&
PUBLIC :: cp_blacs_env_type ! make it accessible only through cp_para_types?
PUBLIC :: cp_blacs_env_create, cp_blacs_env_retain, cp_blacs_env_release
PUBLIC :: start_blacs, end_blacs, cp_blacs_env_write,&
cp_blacs_env_from_globenv
!***
!****************************************************************************
contains
CONTAINS
!!****f* qs_blacs/cp_blacs_env_create [1.0] *
!!
@ -95,51 +106,51 @@ contains
!! 08.2002 created [fawzi]
!!
!!*** **********************************************************************
subroutine cp_blacs_env_create(blacs_env,group,owns_group,source,error)
type(cp_blacs_env_type), pointer :: blacs_env
integer, intent(in) :: group
logical, intent(in), optional :: owns_group
integer, dimension(2), intent(in), optional :: source
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_blacs_env_create(blacs_env,group,owns_group,source,error)
TYPE(cp_blacs_env_type), POINTER :: blacs_env
INTEGER, INTENT(in) :: group
LOGICAL, INTENT(in), OPTIONAL :: owns_group
INTEGER, DIMENSION(2), INTENT(in), OPTIONAL :: source
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_blacs_env_create',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_blacs_env_create',&
routineP=moduleN//':'//routineN
integer :: stat
failure=.false.
INTEGER :: stat
failure=.FALSE.
#ifdef __parallel
#ifndef __BLACS
call cp_assert(.false.,cp_failure_level, cp_assertion_failed,&
fromWhere=routineP,message="to use the blacs environment "//&
CALL cp_assert(.FALSE.,cp_failure_level, cp_assertion_failed,&
fromWhere=routineP,message="to USE the blacs environment "//&
"(used by full matrices) you need the blacs library "//&
CPSourceFileRef,&
error=error)
#endif
#endif
allocate(blacs_env,stat=stat)
ALLOCATE(blacs_env,stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
if (.not. failure) then
IF (.NOT. failure) THEN
blacs_env%group=group
blacs_env%owns_group=.true.
blacs_env%owns_group=.TRUE.
blacs_env%ref_count=1
blacs_env%mepos=0
blacs_env%num_pe=1
blacs_env%source=0
blacs_env%my_pid=0
blacs_env%n_pid=1
if (present(owns_group)) blacs_env%owns_group=owns_group
if (present(source)) then
IF (PRESENT(owns_group)) blacs_env%owns_group=owns_group
IF (PRESENT(source)) THEN
blacs_env%source=source
end if
END IF
#ifdef __BLACS
call blacs_pinfo(blacs_env%my_pid,blacs_env%n_pid)
call blacs_gridinfo(blacs_env%group,blacs_env%num_pe(1),&
CALL blacs_pinfo(blacs_env%my_pid,blacs_env%n_pid)
CALL blacs_gridinfo(blacs_env%group,blacs_env%num_pe(1),&
blacs_env%num_pe(2),blacs_env%mepos(1),blacs_env%mepos(2))
#endif
end if
end subroutine cp_blacs_env_create
END IF
END SUBROUTINE cp_blacs_env_create
!***************************************************************************
!!****f* qs_blacs/cp_blacs_env_retain [1.0] *
@ -171,20 +182,20 @@ end subroutine cp_blacs_env_create
!! 08.2002 created [fawzi]
!!
!!*** **********************************************************************
subroutine cp_blacs_env_retain(blacs_env,error)
type(cp_blacs_env_type), pointer :: blacs_env
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_blacs_env_retain(blacs_env,error)
TYPE(cp_blacs_env_type), POINTER :: blacs_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_blacs_env_retain',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_blacs_env_retain',&
routineP=moduleN//':'//routineN
failure=.false.
CPPrecondition(associated(blacs_env),cp_failure_level,routineP,error,failure)
if (.not. failure) then
failure=.FALSE.
CPPrecondition(ASSOCIATED(blacs_env),cp_failure_level,routineP,error,failure)
IF (.NOT. failure) THEN
CPPrecondition(blacs_env%ref_count>0,cp_failure_level,routineP,error,failure)
blacs_env%ref_count=blacs_env%ref_count+1
end if
end subroutine cp_blacs_env_retain
END IF
END SUBROUTINE cp_blacs_env_retain
!***************************************************************************
!!****f* qs_blacs/cp_blacs_env_release [1.0] *
@ -216,31 +227,31 @@ end subroutine cp_blacs_env_retain
!! 08.2002 created [fawzi]
!!
!!*** **********************************************************************
subroutine cp_blacs_env_release(blacs_env,error)
type(cp_blacs_env_type), pointer :: blacs_env
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_blacs_env_release(blacs_env,error)
TYPE(cp_blacs_env_type), POINTER :: blacs_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_blacs_env_release',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_blacs_env_release',&
routineP=moduleN//':'//routineN
integer :: stat
failure=.false.
INTEGER :: stat
failure=.FALSE.
if (associated(blacs_env)) then
IF (ASSOCIATED(blacs_env)) THEN
CPPrecondition(blacs_env%ref_count>0,cp_failure_level,routineP,error,failure)
blacs_env%ref_count=blacs_env%ref_count-1
if (blacs_env%ref_count<1) then
if (blacs_env%owns_group) then
IF (blacs_env%ref_count<1) THEN
IF (blacs_env%owns_group) THEN
#ifdef __BLACS
call blacs_gridexit(blacs_env%group)
CALL blacs_gridexit(blacs_env%group)
#endif
end if
deallocate(blacs_env,stat=stat)
END IF
DEALLOCATE(blacs_env,stat=stat)
CPPostcondition(stat==0,cp_warning_level,routineP,error,failure)
end if
end if
nullify(blacs_env)
end subroutine cp_blacs_env_release
END IF
END IF
NULLIFY(blacs_env)
END SUBROUTINE cp_blacs_env_release
!***************************************************************************
!!****f* cp_blacs_env/cp_blacs_env_write [1.0] *
@ -275,43 +286,43 @@ end subroutine cp_blacs_env_release
!! 08.2002 created [fawzi]
!!
!!*** **********************************************************************
subroutine cp_blacs_env_write(blacs_env, unit_nr, error)
type(cp_blacs_env_type), pointer :: blacs_env
integer, intent(in) :: unit_nr
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_blacs_env_write(blacs_env, unit_nr, error)
TYPE(cp_blacs_env_type), POINTER :: blacs_env
INTEGER, INTENT(in) :: unit_nr
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_blacs_env_write',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_blacs_env_write',&
routineP=moduleN//':'//routineN
integer :: iostat
failure=.false.
INTEGER :: iostat
failure=.FALSE.
if (associated(blacs_env)) then
write (unit=unit_nr,&
IF (ASSOCIATED(blacs_env)) THEN
WRITE (unit=unit_nr,&
fmt="(' <cp_blacs_env>:{ owns_group=',l1,',')",&
iostat=iostat) blacs_env%owns_group
CPInvariant(iostat==0,cp_failure_level,routineP,error,failure)
write (unit=unit_nr,fmt="(' group=',i10,', ref_count=',i10,',')",&
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)
write (unit=unit_nr,fmt="(' mepos=(',i8,',',i8,'),')",&
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)
write (unit=unit_nr,fmt="(' source=(',i8,',',i8,'),')",&
WRITE (unit=unit_nr,fmt="(' source=(',i8,',',i8,'),')",&
iostat=iostat) blacs_env%source(1), blacs_env%source(2)
CPInvariant(iostat==0,cp_failure_level,routineP,error,failure)
write (unit=unit_nr,fmt="(' num_pe=(',i8,',',i8,'),')",&
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)
write (unit=unit_nr,fmt="(' my_pid=',i10,', n_pid=',i10,' }')",&
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)
else
write (unit=unit_nr,&
ELSE
WRITE (unit=unit_nr,&
fmt="(a)", iostat=iostat) ' <cp_blacs_env>:*null* '
CPInvariant(iostat==0,cp_failure_level,routineP,error,failure)
end if
end subroutine cp_blacs_env_write
END IF
END SUBROUTINE cp_blacs_env_write
!***************************************************************************
!!****f* cp_blacs_env/cp_blacs_env_from_globenv [1.0] *
@ -345,22 +356,22 @@ end subroutine cp_blacs_env_write
!! 08.2002 created [fawzi]
!!
!!*** **********************************************************************
function cp_blacs_env_from_globenv(global_env,error) result(res)
type(cp_blacs_env_type), pointer :: res
type(global_environment_type), intent(in),target :: global_env
type(cp_error_type), optional, intent(inout) :: error
FUNCTION cp_blacs_env_from_globenv(global_env,error) RESULT(res)
TYPE(cp_blacs_env_type), POINTER :: res
TYPE(global_environment_type), INTENT(in),TARGET :: global_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_blacs_env_from_globenv',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_blacs_env_from_globenv',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
CPPrecondition(associated(global_env%blacs_env),cp_failure_level,routineP,error,failure)
CPPrecondition(ASSOCIATED(global_env%blacs_env),cp_failure_level,routineP,error,failure)
!if (failure) then
! call start_blacs(global_env) ! needs intent inout
!end if
res => global_env%blacs_env
end function cp_blacs_env_from_globenv
END FUNCTION cp_blacs_env_from_globenv
!***************************************************************************
SUBROUTINE start_blacs(globenv)
@ -383,7 +394,7 @@ end function cp_blacs_env_from_globenv
INTEGER :: context,group,ipe,istat,mypcol,mype,myprow,npcol,npe,nprow,&
output_unit
LOGICAL :: ionode
type(cp_error_type) :: error
TYPE(cp_error_type) :: error
INTEGER, DIMENSION(:), ALLOCATABLE :: pcol,pcon,prow
@ -397,8 +408,8 @@ end function cp_blacs_env_from_globenv
#ifdef __parallel
#ifndef __BLACS
call cp_assert(.false.,cp_failure_level, cp_assertion_failed,&
fromWhere=routine,message="to use the blacs environment "//&
CALL cp_assert(.FALSE.,cp_failure_level, cp_assertion_failed,&
fromWhere=routine,message="to USE the blacs environment "//&
"(used by full matrices) you need the blacs library "//&
CPSourceFileRef,&
error=error)
@ -471,7 +482,7 @@ end function cp_blacs_env_from_globenv
END IF
#endif
call cp_blacs_env_create(globenv%blacs_env,group = context)
CALL cp_blacs_env_create(globenv%blacs_env,group = context)
END SUBROUTINE start_blacs
@ -498,7 +509,7 @@ end function cp_blacs_env_from_globenv
LOGICAL :: ionode
INTEGER, DIMENSION(:), ALLOCATABLE :: pcon
type(cp_blacs_env_type), pointer :: context
TYPE(cp_blacs_env_type), POINTER :: context
! ---------------------------------------------------------------------------
@ -537,7 +548,7 @@ end function cp_blacs_env_from_globenv
CALL mp_sync(group)
call cp_blacs_env_release(globenv%blacs_env)
CALL cp_blacs_env_release(globenv%blacs_env)
! CALL blacs_gridexit(context)
!globenv%context = 0
@ -549,4 +560,4 @@ end function cp_blacs_env_from_globenv
! *****************************************************************************
end module cp_blacs_env
END MODULE cp_blacs_env

1150
src/cp_block_matrix.F
View file

File diff suppressed because it is too large Load diff

198
src/cp_e_rosenbrok_function.F
View file

@ -25,37 +25,49 @@
!!
!! SOURCE
!*****************************************************************************
module cp_e_rosenbrok_function
use cp_log_handling, only: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log,&
cp_logger_get_default_unit_nr, cp_logger_type
use cp_error_handling, only: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
use kinds, only: wp=>dp
use global_types, only: global_environment_type
use timings, only: timeset, timestop
implicit none
private
MODULE cp_e_rosenbrok_function
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character(len=*), private, parameter :: moduleN='cp_e_rosenbrok_function'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='cp_e_rosenbrok_function'
public :: cp_e_rosenbrok_f_type
PUBLIC :: cp_e_rosenbrok_f_type
public :: cp_init, cp_dealloc_ref, cp_eval_at, cp_ros_f_init, &
PUBLIC :: cp_init, cp_dealloc_ref, cp_eval_at, cp_ros_f_init, &
cp_ros_f_dealloc_ref, cp_ros_f_eval_at, cp_bounds_and_x_ros_f_init
interface cp_init
module procedure cp_ros_f_init
end interface
interface cp_dealloc_ref
module procedure cp_ros_f_dealloc_ref
end interface
interface cp_eval_at
module procedure cp_ros_f_eval_at
end interface
INTERFACE cp_init
MODULE PROCEDURE cp_ros_f_init
END INTERFACE
INTERFACE cp_dealloc_ref
MODULE PROCEDURE cp_ros_f_dealloc_ref
END INTERFACE
INTERFACE cp_eval_at
MODULE PROCEDURE cp_ros_f_eval_at
END INTERFACE
!!***
!****************************************************************************
@ -83,14 +95,14 @@ module cp_e_rosenbrok_function
!!
!! SOURCE
!***************************************************************************
type cp_e_rosenbrok_f_type
logical :: initialized
integer :: n
end type cp_e_rosenbrok_f_type
TYPE cp_e_rosenbrok_f_type
LOGICAL :: initialized
INTEGER :: n
END TYPE cp_e_rosenbrok_f_type
!!***
!****************************************************************************
contains
CONTAINS
!!****f* cp_e_rosenbrok_f_type/cp_ros_f_init [1.0] *
@ -125,22 +137,22 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_ros_f_init(rf_env, n, error)
type(cp_e_rosenbrok_f_type), intent(inout) :: rf_env
integer, intent(in) :: n
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_ros_f_init(rf_env, n, error)
TYPE(cp_e_rosenbrok_f_type), INTENT(inout) :: rf_env
INTEGER, INTENT(in) :: n
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
integer :: handle
character(len=*), parameter :: routineN='cp_ros_f_init',&
LOGICAL :: failure
INTEGER :: handle
CHARACTER(len=*), PARAMETER :: routineN='cp_ros_f_init',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
!call timeset(routineN//','//moduleN,'I',"",handle)
rf_env%initialized=.true.
rf_env%initialized=.TRUE.
rf_env%n=n
!call timestop(0.0_wp,handle)
end subroutine cp_ros_f_init
END SUBROUTINE cp_ros_f_init
!***************************************************************************
!!****f* cp_e_rosenbrok_f_type/cp_ros_f_dealloc_ref [1.0] *
@ -173,18 +185,18 @@ end subroutine cp_ros_f_init
!! none
!!
!!*** **********************************************************************
subroutine cp_ros_f_dealloc_ref(rf_env, error)
type(cp_e_rosenbrok_f_type), intent(inout) :: rf_env
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_ros_f_dealloc_ref(rf_env, error)
TYPE(cp_e_rosenbrok_f_type), INTENT(inout) :: rf_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_ros_f_dealloc_ref',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_ros_f_dealloc_ref',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
CPPrecondition(rf_env%initialized,cp_failure_level,routineP,error,failure)
rf_env%initialized=.false.
end subroutine cp_ros_f_dealloc_ref
rf_env%initialized=.FALSE.
END SUBROUTINE cp_ros_f_dealloc_ref
!***************************************************************************
!!****f* cp_e_rosenbrok_f_type/cp_ros_f_eval_at [1.0] *
@ -223,45 +235,45 @@ end subroutine cp_ros_f_dealloc_ref
!! none
!!
!!*** **********************************************************************
subroutine cp_ros_f_eval_at(rf_env, x, f, gradient, error)
type(cp_e_rosenbrok_f_type), intent(in) :: rf_env
real(kind=wp), dimension(:), intent(in) :: x
real(kind=wp), intent(out), optional :: f
real(kind=wp), intent(out), dimension(:), optional :: gradient
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_ros_f_eval_at(rf_env, x, f, gradient, error)
TYPE(cp_e_rosenbrok_f_type), INTENT(in) :: rf_env
REAL(kind=wp), DIMENSION(:), INTENT(in) :: x
REAL(kind=wp), INTENT(out), OPTIONAL :: f
REAL(kind=wp), INTENT(out), DIMENSION(:), OPTIONAL :: gradient
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
integer :: handle, i
character(len=*), parameter :: routineN='cp_ros_f_eval_at',&
LOGICAL :: failure
INTEGER :: handle, i
CHARACTER(len=*), PARAMETER :: routineN='cp_ros_f_eval_at',&
routineP=moduleN//':'//routineN
real(kind=wp) :: t1,t2
failure=.false.
REAL(kind=wp) :: t1,t2
failure=.FALSE.
CPPrecondition(rf_env%initialized,cp_failure_level,routineP,error,failure)
CPPrecondition(size(x)==rf_env%n,cp_warning_level,routineP,error,failure)
CPPrecondition(SIZE(x)==rf_env%n,cp_warning_level,routineP,error,failure)
!call timeset(routineN//','//moduleN,'I',"",handle)
if (present(f)) then
IF (PRESENT(f)) THEN
f = 0.25_wp * (x (1) - 1.0_wp) **2
do i = 2, rf_env%n
DO i = 2, rf_env%n
f = f + (x (i) - x (i - 1) **2) **2
end do
END DO
f = 4.0_wp * f
end if
if (present(gradient)) then
END IF
IF (PRESENT(gradient)) THEN
! Compute gradient g for the sample problem.
t1 = x (2) - x (1) **2
if (rf_env%n>0) then ! right if n==1 ??
IF (rf_env%n>0) THEN ! right if n==1 ??
gradient (1) = 2.0_wp * (x (1) - 1.0_wp) - 16_wp * x (1) * t1
do i = 2, rf_env%n - 1
DO i = 2, rf_env%n - 1
t2 = t1
t1 = x (i + 1) - x (i) **2
gradient(i) = 8.0_wp * t2 - 16_wp * x (i) * t1
end do
END DO
gradient (rf_env%n) = 8.0_wp * t1
end if
end if
END IF
END IF
!call timestop(0.0_wp,handle)
end subroutine cp_ros_f_eval_at
END SUBROUTINE cp_ros_f_eval_at
!***************************************************************************
!!****f* cp_e_rosenbrok_function/cp_bounds_and_x_ros_f_init [1.0] *
@ -304,42 +316,42 @@ end subroutine cp_ros_f_eval_at
!! none
!!
!!*** **********************************************************************
subroutine cp_bounds_and_x_ros_f_init(lower_bound, upper_bound, kind_of_bound,&
SUBROUTINE cp_bounds_and_x_ros_f_init(lower_bound, upper_bound, kind_of_bound,&
x0,rf_env, error)
real(kind=wp), dimension(:), intent(out) :: lower_bound, upper_bound, x0
integer, dimension(:), intent(out) :: kind_of_bound
type(cp_e_rosenbrok_f_type), intent(in) :: rf_env
type(cp_error_type), optional, intent(inout) :: error
REAL(kind=wp), DIMENSION(:), INTENT(out) :: lower_bound, upper_bound, x0
INTEGER, DIMENSION(:), INTENT(out) :: kind_of_bound
TYPE(cp_e_rosenbrok_f_type), INTENT(in) :: rf_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
integer :: handle, i
character(len=*), parameter :: routineN='cp_bounds_ros_f_init',&
LOGICAL :: failure
INTEGER :: handle, i
CHARACTER(len=*), PARAMETER :: routineN='cp_bounds_ros_f_init',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
!call timeset(routineN//','//moduleN,'I',"",handle)
CPPrecondition(rf_env%initialized,cp_failure_level,routineP,error,failure)
CPPrecondition(size(lower_bound)==rf_env%n,cp_failure_level,routineP,error,failure)
CPPrecondition(size(upper_bound)==rf_env%n,cp_failure_level,routineP,error,failure)
CPPrecondition(size(kind_of_bound)==rf_env%n,cp_failure_level,routineP,error,failure)
CPPrecondition(size(x0)==rf_env%n,cp_failure_level,routineP,error,failure)
if (.not. failure) then
CPPrecondition(SIZE(lower_bound)==rf_env%n,cp_failure_level,routineP,error,failure)
CPPrecondition(SIZE(upper_bound)==rf_env%n,cp_failure_level,routineP,error,failure)
CPPrecondition(SIZE(kind_of_bound)==rf_env%n,cp_failure_level,routineP,error,failure)
CPPrecondition(SIZE(x0)==rf_env%n,cp_failure_level,routineP,error,failure)
IF (.NOT. failure) THEN
! odd numbered variables
do i = 1, rf_env%n, 2
DO i = 1, rf_env%n, 2
kind_of_bound=2
lower_bound (i) = 1.0_wp
upper_bound (i) = 100.0_wp
end do
END DO
! even-numbered variables.
do i = 2, rf_env%n, 2
DO i = 2, rf_env%n, 2
kind_of_bound=2
lower_bound (i) = - 100.0_wp
upper_bound (i) = 100.0_wp
end do
END DO
x0=3.0_wp
end if
END IF
!call timestop(0.0_wp,handle)
end subroutine cp_bounds_and_x_ros_f_init
END SUBROUTINE cp_bounds_and_x_ros_f_init
!***************************************************************************
end module cp_e_rosenbrok_function
END MODULE cp_e_rosenbrok_function

14
src/cp_error_handling.F
View file

@ -996,25 +996,25 @@ END SUBROUTINE cp_unimplemented_error
!!
!!
!!****
subroutine cp_simple_assert(condition, routineP, line)
SUBROUTINE cp_simple_assert(condition, routineP, line)
implicit none
IMPLICIT NONE
! arguments
logical, intent(in) :: condition
character(len=*), intent(in) :: routineP
integer, intent(in) :: line
LOGICAL, INTENT(in) :: condition
CHARACTER(len=*), INTENT(in) :: routineP
INTEGER, INTENT(in) :: line
! locals
! code
IF (.NOT.condition) then
IF (.NOT.condition) THEN
WRITE (*,*) "======== ASSERTION FAILED ========"
WRITE (*,*) routineP, ": ", cp_to_string(line)
STOP 1
END IF
end subroutine cp_simple_assert
END SUBROUTINE cp_simple_assert
! *****************************************************************************

8
src/cp_fm_basic_linalg.F
View file

@ -39,11 +39,11 @@ MODULE cp_fm_basic_linalg
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_fm_struct, ONLY: cp_fm_struct_type,&
cp_fm_struct_create,&
USE cp_fm_struct, ONLY: cp_fm_struct_create,&
cp_fm_struct_equivalent,&
cp_fm_struct_release,&
cp_fm_struct_retain
cp_fm_struct_retain,&
cp_fm_struct_type
USE cp_fm_types, ONLY: cp_fm_create,&
cp_fm_create2,&
cp_fm_get_info,&
@ -181,7 +181,7 @@ CONTAINS
ELSE
#ifdef __SCALAPACK
CALL cp_unimplemented_error(fromWhere=routineP, &
message="to do (pdscal,pdcopy,pdaxpy)", error=error)
message="to DO (pdscal,pdcopy,pdaxpy)", error=error)
#else
CPAssert(.FALSE.,cp_failure_level,routineP,error,failure)
#endif

30
src/cp_fm_cholesky.F
View file

@ -25,20 +25,30 @@
!! SOURCE
!****************************************************************************
MODULE cp_fm_cholesky
USE cp_log_handling, ONLY: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log
USE cp_error_handling, ONLY: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
USE kinds, ONLY: wp=>dp
USE cp_para_types, ONLY: cp_para_env_type
USE cp_fm_types, ONLY: cp_fm_get_info,&
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_fm_types, ONLY: cp_fm_get_info,&
cp_full_matrix_p_type,&
cp_full_matrix_type
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_para_types, ONLY: cp_blacs_env_type,&
cp_para_env_type
USE timings, ONLY: timeset, timestop
USE kinds, ONLY: wp=>dp
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE

6
src/cp_fm_pool_types.F
View file

@ -35,9 +35,9 @@ MODULE cp_fm_pool_types
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_fm_struct, ONLY: cp_fm_struct_type,&
cp_fm_struct_release,&
cp_fm_struct_retain
USE cp_fm_struct, ONLY: cp_fm_struct_release,&
cp_fm_struct_retain,&
cp_fm_struct_type
USE cp_fm_types, ONLY: cp_fm_create,&
cp_fm_release,&
cp_full_matrix_p_type,&

8
src/cp_fm_struct.F
View file

@ -243,12 +243,12 @@ SUBROUTINE cp_fm_struct_create(fmstruct,para_env,context, nrow_global,&
IF (PRESENT(nrow_global)) fmstruct%nrow_global=nrow_global
IF (PRESENT(ncol_global)) fmstruct%ncol_global=ncol_global
! checks for more processes than matrix elements
call cp_assert(fmstruct%context%num_pe(1)<=fmstruct%nrow_global,&
CALL cp_assert(fmstruct%context%num_pe(1)<=fmstruct%nrow_global,&
cp_warning_level,cp_assertion_failed,routineP,&
"context%num_pe(1)<=nrow_global"//&
CPSourceFileRef,&
error)
call cp_assert(fmstruct%context%num_pe(2)<=fmstruct%ncol_global,&
CALL cp_assert(fmstruct%context%num_pe(2)<=fmstruct%ncol_global,&
cp_warning_level,cp_assertion_failed,routineP,&
"context%num_pe(2)<=ncol_global"//&
CPSourceFileRef,&
@ -568,7 +568,7 @@ SUBROUTINE cp_fm_struct_write(fmstruct, unit_nr, long_description,error)
WRITE (unit=unit_nr,fmt="(a)",iostat=iostat) "),"
ELSE
WRITE (unit=unit_nr,&
fmt="(' row_indices=<integer,dimension(',i8,'),')",&
fmt="(' row_indices=<INTEGER,DIMENSION(',i8,'),')",&
iostat=iostat) SIZE(fmstruct%row_indices)
END IF
ELSE
@ -581,7 +581,7 @@ SUBROUTINE cp_fm_struct_write(fmstruct, unit_nr, long_description,error)
WRITE (unit=unit_nr,fmt="(a)",iostat=iostat) "),"
ELSE
WRITE (unit=unit_nr,&
fmt="(' col_indices=<integer,dimension(',i8,'),')",&
fmt="(' col_indices=<INTEGER,DIMENSION(',i8,'),')",&
iostat=iostat) SIZE(fmstruct%col_indices)
END IF
ELSE

6
src/cp_fm_types.F
View file

@ -45,11 +45,11 @@ MODULE cp_fm_types
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_fm_struct, ONLY: cp_fm_struct_type,&
cp_fm_struct_create,&
USE cp_fm_struct, ONLY: cp_fm_struct_create,&
cp_fm_struct_equivalent,&
cp_fm_struct_release,&
cp_fm_struct_retain,&
cp_fm_struct_type,&
cp_fm_struct_write
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
@ -1072,7 +1072,7 @@ CONTAINS
ELSE IF (loc) THEN
IF (ASSOCIATED(matrix%local_data)) THEN
WRITE (unit=unit_nr,&
fmt="(' local_data=(real(wp, dimension(',i8,', ',i8,'))')",&
fmt="(' local_data=(REAL(wp, DIMENSION(',i8,', ',i8,'))')",&
iostat=iostat) SIZE(matrix%local_data,1), SIZE(matrix%local_data,2)
END IF
END IF

8
src/cp_fm_utils.F
View file

@ -95,7 +95,7 @@ CONTAINS
CALL mp_sum(element, mat_a%matrix_struct%para_env%group)
#endif
IF (element/=vec_b(row)) THEN
WRITE (*,*) routineP//': inconsistent data'
WRITE (*,*) routineP//': inconsistent DATA'
STOP 1
END IF
END DO
@ -150,7 +150,7 @@ CONTAINS
CALL mp_sum(element, mat_b%matrix_struct%para_env%group)
#endif
IF (element/=vec_a(row)) THEN
WRITE (*,*) routineP//': Inconsistent data'
WRITE (*,*) routineP//': Inconsistent DATA'
STOP 1
END IF
END DO
@ -209,7 +209,7 @@ CONTAINS
CALL mp_sum(element, mat_a%matrix_struct%para_env%group)
#endif
IF (element/=vec_b(((col-1)*a_row_global)+row)) THEN
WRITE (*,*) routineP//': Inconsistent data'
WRITE (*,*) routineP//': Inconsistent DATA'
STOP 1
END IF
END DO
@ -266,7 +266,7 @@ CONTAINS
CALL mp_sum(element, mat_b%matrix_struct%para_env%group)
#endif
IF (element/=vec_a(((col-1)*b_row_global)+row)) THEN
WRITE (*,*) routineP//': Inconsistent data'
WRITE (*,*) routineP//': Inconsistent DATA'
STOP 1
END IF
END DO

4
src/cp_fm_vect.F
View file

@ -39,11 +39,11 @@ MODULE cp_fm_vect
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_fm_struct, ONLY: cp_fm_struct_type,&
cp_fm_struct_create,&
USE cp_fm_struct, ONLY: cp_fm_struct_create,&
cp_fm_struct_equivalent,&
cp_fm_struct_release,&
cp_fm_struct_retain,&
cp_fm_struct_type,&
optimal_blacs_col_block_size,&
optimal_blacs_row_block_size
USE cp_fm_types, ONLY: cp_fm_create,&

2201
src/cp_lbfgs.F
View file

File diff suppressed because it is too large Load diff

42
src/cp_lbfgs_optimizer_e_rosen.F
View file

@ -32,16 +32,26 @@
!! SOURCE
!*****************************************************************************
MODULE cp_lbfgs_optimizer_e_rosen
USE cp_lbfgs, ONLY: setulb, cp_lbfgs_unit_nr
USE cp_error_handling, ONLY: cp_assert, cp_error_message, cp_error_type,&
cp_assertion_failed, cp_error_get_logger
USE cp_log_handling, ONLY: cp_to_string, cp_warning_level, cp_failure_level,&
cp_std_out_unit_nr, cp_logger_get_default_unit_nr, cp_logger_type
USE kinds, ONLY: wp=>dp
USE global_types, ONLY: global_environment_type
USE timings, ONLY: timeset, timestop
USE message_passing, ONLY: mp_bcast
USE cp_e_rosenbrok_function, ONLY: cp_e_rosenbrok_f_type, cp_eval_at
USE cp_e_rosenbrok_function, ONLY: cp_e_rosenbrok_f_type,&
cp_eval_at
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_error_get_logger,&
cp_error_message,&
cp_error_type
USE cp_lbfgs, ONLY: cp_lbfgs_unit_nr,&
setulb
USE cp_log_handling, ONLY: cp_failure_level,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_std_out_unit_nr,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE message_passing, ONLY: mp_bcast
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
@ -180,7 +190,7 @@ MODULE cp_lbfgs_optimizer_e_rosen
REAL(kind=wp), DIMENSION(:), POINTER :: x,lower_bound,upper_bound,&
gradient,dsave,work_array
TYPE(global_environment_type), POINTER :: global_env
type(cp_e_rosenbrok_f_type), POINTER :: obj_funct
TYPE(cp_e_rosenbrok_f_type), POINTER :: obj_funct
END TYPE cp_lbfgs_opt_e_rosen_type
!!***
!****************************************************************************
@ -236,7 +246,7 @@ CONTAINS
lower_bound,upper_bound, kind_of_bound, master, max_f_per_iter, error)
TYPE(cp_lbfgs_opt_e_rosen_type), INTENT(out) :: optimizer
TYPE(global_environment_type), INTENT(in), TARGET :: global_env
type(cp_e_rosenbrok_f_type), INTENT(in), TARGET :: obj_funct
TYPE(cp_e_rosenbrok_f_type), INTENT(in), TARGET :: obj_funct
REAL(kind=wp), DIMENSION(:), INTENT(in) :: x0
INTEGER, INTENT(in), OPTIONAL :: m,print_every, master, max_f_per_iter
REAL(kind=wp), INTENT(in), OPTIONAL ::wanted_projected_gradient,&
@ -464,7 +474,7 @@ CONTAINS
is_master, last_f, f, error)
TYPE(cp_lbfgs_opt_e_rosen_type), INTENT(in) :: optimizer
TYPE(global_environment_type), POINTER, OPTIONAL :: global_env
type(cp_e_rosenbrok_f_type), POINTER, OPTIONAL :: obj_funct
TYPE(cp_e_rosenbrok_f_type), POINTER, OPTIONAL :: obj_funct
REAL(kind=wp), DIMENSION(:), POINTER, OPTIONAL :: x
INTEGER, INTENT(out), OPTIONAL :: m, print_every, n_var, n_iter, master,&
status, max_f_per_iter
@ -657,7 +667,7 @@ CONTAINS
ELSE IF (optimizer%task(1:4)=='STOP') THEN
optimizer%status=5
CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,&
routineP,"task became stop in an unknown way in "//&
routineP,"task became STOP in an unknown way in "//&
CPSourceFileRef,&
error)
ELSE IF (optimizer%task(1:5)=='ERROR') THEN
@ -928,9 +938,9 @@ CONTAINS
! files are almost the same (multi-line use change it a bit)
! [template(type1,nametype1,USE)]
! ARGS:
! type1 = "type(cp_e_rosenbrok_f_type)"
! nametype1 = "e_rosen"
! USE = "USE cp_e_rosenbrok_function, ONLY: cp_e_rosenbrok_f_type, cp_eval_at"
! nametype1 = "e_rosen"
! type1 = "type(cp_e_rosenbrok_f_type)"
END MODULE cp_lbfgs_optimizer_e_rosen

42
src/cp_lbfgs_optimizer_gerd_f.F
View file

@ -32,16 +32,26 @@
!! SOURCE
!*****************************************************************************
MODULE cp_lbfgs_optimizer_gerd_f
USE cp_lbfgs, ONLY: setulb, cp_lbfgs_unit_nr
USE cp_error_handling, ONLY: cp_assert, cp_error_message, cp_error_type,&
cp_assertion_failed, cp_error_get_logger
USE cp_log_handling, ONLY: cp_to_string, cp_warning_level, cp_failure_level,&
cp_std_out_unit_nr, cp_logger_get_default_unit_nr, cp_logger_type
USE kinds, ONLY: wp=>dp
USE global_types, ONLY: global_environment_type
USE timings, ONLY: timeset, timestop
USE message_passing, ONLY: mp_bcast
USE pao_obj_function, ONLY: pao_gerd_functional_type, cp_eval_at
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_error_get_logger,&
cp_error_message,&
cp_error_type
USE cp_lbfgs, ONLY: cp_lbfgs_unit_nr,&
setulb
USE cp_log_handling, ONLY: cp_failure_level,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_std_out_unit_nr,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE message_passing, ONLY: mp_bcast
USE pao_obj_function, ONLY: cp_eval_at,&
pao_gerd_functional_type
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
@ -180,7 +190,7 @@ MODULE cp_lbfgs_optimizer_gerd_f
REAL(kind=wp), DIMENSION(:), POINTER :: x,lower_bound,upper_bound,&
gradient,dsave,work_array
TYPE(global_environment_type), POINTER :: global_env
type(pao_gerd_functional_type), POINTER :: obj_funct
TYPE(pao_gerd_functional_type), POINTER :: obj_funct
END TYPE cp_lbfgs_opt_gerd_f_type
!!***
!****************************************************************************
@ -236,7 +246,7 @@ CONTAINS
lower_bound,upper_bound, kind_of_bound, master, max_f_per_iter, error)
TYPE(cp_lbfgs_opt_gerd_f_type), INTENT(out) :: optimizer
TYPE(global_environment_type), INTENT(in), TARGET :: global_env
type(pao_gerd_functional_type), INTENT(in), TARGET :: obj_funct
TYPE(pao_gerd_functional_type), INTENT(in), TARGET :: obj_funct
REAL(kind=wp), DIMENSION(:), INTENT(in) :: x0
INTEGER, INTENT(in), OPTIONAL :: m,print_every, master, max_f_per_iter
REAL(kind=wp), INTENT(in), OPTIONAL ::wanted_projected_gradient,&
@ -464,7 +474,7 @@ CONTAINS
is_master, last_f, f, error)
TYPE(cp_lbfgs_opt_gerd_f_type), INTENT(in) :: optimizer
TYPE(global_environment_type), POINTER, OPTIONAL :: global_env
type(pao_gerd_functional_type), POINTER, OPTIONAL :: obj_funct
TYPE(pao_gerd_functional_type), POINTER, OPTIONAL :: obj_funct
REAL(kind=wp), DIMENSION(:), POINTER, OPTIONAL :: x
INTEGER, INTENT(out), OPTIONAL :: m, print_every, n_var, n_iter, master,&
status, max_f_per_iter
@ -657,7 +667,7 @@ CONTAINS
ELSE IF (optimizer%task(1:4)=='STOP') THEN
optimizer%status=5
CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,&
routineP,"task became stop in an unknown way in "//&
routineP,"task became STOP in an unknown way in "//&
CPSourceFileRef,&
error)
ELSE IF (optimizer%task(1:5)=='ERROR') THEN
@ -928,9 +938,9 @@ CONTAINS
! files are almost the same (multi-line use change it a bit)
! [template(type1,nametype1,USE)]
! ARGS:
! type1 = "type(pao_gerd_functional_type)"
! nametype1 = "gerd_f"
! USE = "USE pao_obj_function, ONLY: pao_gerd_functional_type, cp_eval_at"
! nametype1 = "gerd_f"
! type1 = "type(pao_gerd_functional_type)"
END MODULE cp_lbfgs_optimizer_gerd_f

123
src/cp_lbfgs_optimizer_tests.F
View file

@ -24,29 +24,46 @@
!! none
!!
!!*** ************************************************************************
module cp_lbfgs_optimizer_tests
use cp_log_handling, only: cp_to_string, cp_failure_level, cp_warning_level,&
cp_log, cp_logger_type, cp_note_level
use cp_error_handling, only: cp_error_type, cp_assert, cp_error_message,&
cp_assertion_failed, cp_debug, cp_precondition_failed, cp_error_init,&
cp_error_dealloc_ref, cp_error_get_logger, cp_error_get_print_level
use kinds, only: wp=>dp
use global_types, only: global_environment_type
use timings, only: timeset, timestop
use cp_lbfgs_optimizer_e_rosen, only: cp_lbfgs_opt_e_rosen_type,&
cp_init, cp_dealloc_ref, cp_next, cp_get
use cp_e_rosenbrok_function, only: cp_e_rosenbrok_f_type,&
cp_ros_f_init, cp_bounds_and_x_ros_f_init, cp_dealloc_ref
implicit none
private
MODULE cp_lbfgs_optimizer_tests
USE cp_e_rosenbrok_function, ONLY: cp_bounds_and_x_ros_f_init,&
cp_dealloc_ref,&
cp_e_rosenbrok_f_type,&
cp_ros_f_init
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_get_print_level,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_precondition_failed
USE cp_lbfgs_optimizer_e_rosen, ONLY: cp_dealloc_ref,&
cp_get,&
cp_init,&
cp_lbfgs_opt_e_rosen_type,&
cp_next
USE cp_log_handling, ONLY: cp_failure_level,&
cp_log,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character(len=*), private, parameter :: moduleN='cp_lbfgs_optimizer_tests'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='cp_lbfgs_optimizer_tests'
public :: cp_lbfgs_e_rosen_test
PUBLIC :: cp_lbfgs_e_rosen_test
!****************************************************************************
contains
CONTAINS
!!****f* cp_lbfgs_optimizer_tests/cp_lbfgs_e_rosen_test [1.0] *
!!
@ -79,54 +96,54 @@ contains
!! none
!!
!!*** **********************************************************************
function cp_lbfgs_e_rosen_test(global_env,error) result(res)
type(global_environment_type), intent(in), target :: global_env
type(cp_error_type), optional, intent(inout) :: error
logical :: res
FUNCTION cp_lbfgs_e_rosen_test(global_env,error) RESULT(res)
TYPE(global_environment_type), INTENT(in), TARGET :: global_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
LOGICAL :: res
logical :: failure, finished
integer :: handle, i, print_every
integer, parameter :: n=25
integer, dimension(n) :: kind_of_bound
real(kind=wp), dimension(n) :: lower_bound, upper_bound, x0
real(kind=wp) :: f
character(len=*), parameter :: routineN='cp_lbfgs_e_rosen_test',&
LOGICAL :: failure, finished
INTEGER :: handle, i, print_every
INTEGER, PARAMETER :: n=25
INTEGER, DIMENSION(n) :: kind_of_bound
REAL(kind=wp), DIMENSION(n) :: lower_bound, upper_bound, x0
REAL(kind=wp) :: f
CHARACTER(len=*), PARAMETER :: routineN='cp_lbfgs_e_rosen_test',&
routineP=moduleN//':'//routineN
type(cp_lbfgs_opt_e_rosen_type) :: optimizer
type(cp_e_rosenbrok_f_type) :: obj_f
failure=.false.
TYPE(cp_lbfgs_opt_e_rosen_type) :: optimizer
TYPE(cp_e_rosenbrok_f_type) :: obj_f
failure=.FALSE.
call timeset(routineN//','//moduleN,'I',"",handle)
if (.not. failure) then
call cp_ros_f_init(obj_f, n=n, error=error)
call cp_bounds_and_x_ros_f_init(lower_bound=lower_bound,&
CALL timeset(routineN//','//moduleN,'I',"",handle)
IF (.NOT. failure) THEN
CALL cp_ros_f_init(obj_f, n=n, error=error)
CALL cp_bounds_and_x_ros_f_init(lower_bound=lower_bound,&
upper_bound=upper_bound,kind_of_bound=kind_of_bound,&
x0=x0,rf_env=obj_f,error=error)
print_every=cp_error_get_print_level(error)
if (print_every < cp_warning_level) then
IF (print_every < cp_warning_level) THEN
print_every=1
else if (print_every==cp_warning_level) then
ELSE IF (print_every==cp_warning_level) THEN
print_every=0
else
ELSE
print_every=-1
end if
call cp_init(optimizer, global_env, obj_f,x0,&
END IF
CALL cp_init(optimizer, global_env, obj_f,x0,&
print_every=print_every, wanted_relative_f_delta=1.0e7_wp,&
wanted_projected_gradient=1.0e-7_wp,lower_bound=lower_bound,&
upper_bound=upper_bound, kind_of_bound=kind_of_bound,&
m=5,error=error)
do i=1,100
if (.not.cp_next(optimizer)) exit
end do
call cp_get(optimizer, f=f, at_end=finished)
DO i=1,100
IF (.not.cp_next(optimizer)) EXIT
END DO
CALL cp_get(optimizer, f=f, at_end=finished)
CPPostcondition(finished,cp_warning_level,routineP,error,failure)
CPPostcondition(f<2.0e7*epsilon(0.0_wp),cp_warning_level,routineP,error,failure)
call cp_dealloc_ref(optimizer,error=error)
call cp_dealloc_ref(obj_f,error=error)
end if
CPPostcondition(f<2.0e7*EPSILON(0.0_wp),cp_warning_level,routineP,error,failure)
CALL cp_dealloc_ref(optimizer,error=error)
CALL cp_dealloc_ref(obj_f,error=error)
END IF
res=.not.failure
call timestop(0.0_wp,handle)
end function cp_lbfgs_e_rosen_test
CALL timestop(0.0_wp,handle)
END FUNCTION cp_lbfgs_e_rosen_test
!***************************************************************************
end module cp_lbfgs_optimizer_tests
END MODULE cp_lbfgs_optimizer_tests

98
src/cp_linked_list_int_ptr.F
View file

@ -35,18 +35,32 @@
!! SOURCE
!*****************************************************************************
MODULE cp_linked_list_int_ptr
USE cp_log_handling, ONLY: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log,&
cp_logger_get_default_unit_nr, cp_logger_type
USE cp_error_handling, ONLY: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
USE cp_output_handling, ONLY: cp_finished_output, cp_would_output,&
cp_unitnr_for_output, cp_write_output
USE kinds, ONLY: wp=>dp
USE timings, ONLY: timeset, timestop
USE cp_array_i_utils, ONLY: cp_i_write
USE cp_array_i_utils, ONLY: cp_i_write
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_output_handling, ONLY: cp_finished_output,&
cp_unitnr_for_output,&
cp_would_output,&
cp_write_output
USE kinds, ONLY: wp=>dp
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
@ -203,7 +217,7 @@ MODULE cp_linked_list_int_ptr
!***************************************************************************
TYPE cp_sll_int_ptr_type
LOGICAL :: initialized
integer, pointer :: first_el
INTEGER, POINTER :: first_el
TYPE(cp_sll_int_ptr_type), POINTER :: rest
END TYPE cp_sll_int_ptr_type
!!***
@ -240,7 +254,7 @@ CONTAINS
!!*** **********************************************************************
SUBROUTINE cp_sll_int_ptr_create(sll,first_el,rest,error)
TYPE(cp_sll_int_ptr_type), POINTER :: sll
integer, intent(in),target, OPTIONAL :: first_el
INTEGER, INTENT(in),TARGET, OPTIONAL :: first_el
TYPE(cp_sll_int_ptr_type), POINTER, OPTIONAL :: rest
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -373,7 +387,7 @@ CONTAINS
!!*** **********************************************************************
SUBROUTINE cp_sll_int_ptr_set(sll,first_el,rest,error)
TYPE(cp_sll_int_ptr_type), POINTER :: sll
integer, intent(in),target, OPTIONAL :: first_el
INTEGER, INTENT(in),TARGET, OPTIONAL :: first_el
TYPE(cp_sll_int_ptr_type), POINTER, OPTIONAL :: rest
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -425,7 +439,7 @@ CONTAINS
!!*** **********************************************************************
SUBROUTINE cp_sll_int_ptr_get(sll,first_el,rest,empty,length,error)
TYPE(cp_sll_int_ptr_type), POINTER :: sll
integer, pointer, OPTIONAL :: first_el
INTEGER, POINTER, OPTIONAL :: first_el
TYPE(cp_sll_int_ptr_type), OPTIONAL, POINTER :: rest
LOGICAL, OPTIONAL, INTENT(out) :: empty
INTEGER, INTENT(out), OPTIONAL :: length
@ -479,7 +493,7 @@ CONTAINS
FUNCTION cp_sll_int_ptr_get_first_el(sll,error) RESULT(res)
TYPE(cp_sll_int_ptr_type), POINTER :: sll
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
integer, pointer :: res
INTEGER, POINTER :: res
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineP='cp_linked_list_int_ptr:cp_sll_int_ptr_get_first'
@ -545,7 +559,7 @@ CONTAINS
res => res%rest
ELSE
CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,&
routineP, "tried to go past end in "// &
routineP, "tried to go past END in "// &
CPSourceFileRef,&
error,failure)
END IF
@ -557,7 +571,7 @@ CONTAINS
res => res%rest
ELSE
CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,&
routineP, "tried to go past end in "// &
routineP, "tried to go past END in "// &
CPSourceFileRef,&
error,failure)
END IF
@ -680,7 +694,7 @@ CONTAINS
!!
!!*** **********************************************************************
FUNCTION cp_sll_int_ptr_get_el_at(sll,index,error) RESULT(res)
integer, pointer :: res
INTEGER, POINTER :: res
TYPE(cp_sll_int_ptr_type), POINTER :: sll
INTEGER, INTENT(in) :: index
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -732,7 +746,7 @@ CONTAINS
!!
!!*** **********************************************************************
SUBROUTINE cp_sll_int_ptr_set_el_at(sll,index,value,error)
integer, intent(in),target :: value
INTEGER, INTENT(in),TARGET :: value
TYPE(cp_sll_int_ptr_type), POINTER :: sll
INTEGER, INTENT(in) :: index
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -784,7 +798,7 @@ CONTAINS
FUNCTION cp_sll_int_ptr_next(iterator,el_att,error) RESULT(res)
TYPE(cp_sll_int_ptr_type), POINTER :: iterator
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
integer, pointer, OPTIONAL :: el_att
INTEGER, POINTER, OPTIONAL :: el_att
LOGICAL :: res
LOGICAL :: failure
@ -833,7 +847,7 @@ CONTAINS
!!*** **********************************************************************
SUBROUTINE cp_sll_int_ptr_insert_el(sll,element,error)
TYPE(cp_sll_int_ptr_type), POINTER :: sll
integer, intent(in),target:: element
INTEGER, INTENT(in),TARGET:: element
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
LOGICAL :: failure
@ -921,7 +935,7 @@ CONTAINS
!!
!!*** **********************************************************************
SUBROUTINE cp_sll_int_ptr_insert_el_at(sll,element,index,error)
integer, intent(in),target :: element
INTEGER, INTENT(in),TARGET :: element
INTEGER, INTENT(in) :: index
TYPE(cp_sll_int_ptr_type), POINTER :: sll
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -1158,7 +1172,7 @@ CONTAINS
TYPE(cp_sll_int_ptr_type), POINTER :: iterator
CHARACTER(len=*), PARAMETER :: routineN='cp_sll_int_ptr_write',&
routineP=moduleN//':'//routineN
integer, pointer :: el
INTEGER, POINTER :: el
failure=.FALSE.
iterator => sll
@ -1196,7 +1210,7 @@ CONTAINS
FUNCTION cp_sll_int_ptr_to_array(sll,error) RESULT(res)
TYPE(cp_sll_int_ptr_type), POINTER :: sll
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
integer, DIMENSION(:), POINTER :: res
INTEGER, DIMENSION(:), POINTER :: res
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_sll_int_ptr_to_array',&
@ -1244,7 +1258,7 @@ END FUNCTION cp_sll_int_ptr_to_array
!!
!!*** **********************************************************************
FUNCTION cp_sll_int_ptr_from_array(array,error) RESULT(res)
integer, DIMENSION(:), INTENT(in) :: array
INTEGER, DIMENSION(:), INTENT(in) :: array
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
TYPE(cp_sll_int_ptr_type), POINTER :: res
@ -1303,7 +1317,7 @@ END FUNCTION cp_sll_int_ptr_from_array
SUBROUTINE cp_sll_int_ptr_insert_ordered(sll,el,insert_equals,&
did_insert,pos,error)
TYPE(cp_sll_int_ptr_type), POINTER :: sll
integer, intent(in),target :: el
INTEGER, INTENT(in),TARGET :: el
LOGICAL, OPTIONAL, INTENT(in) :: insert_equals
LOGICAL, OPTIONAL, INTENT(out) :: did_insert
TYPE(cp_sll_int_ptr_type), POINTER, OPTIONAL :: pos
@ -1384,12 +1398,12 @@ END SUBROUTINE cp_sll_int_ptr_insert_ordered
SUBROUTINE cp_sll_int_ptr_insert_ordered2(sll,el,compare_function,&
insert_equals,error)
TYPE(cp_sll_int_ptr_type), POINTER :: sll
integer, intent(in),target :: el
INTEGER, INTENT(in),TARGET :: el
INTERFACE
FUNCTION compare_function(el1,el2)
USE cp_array_i_utils, ONLY: cp_i_write
INTEGER :: compare_function
integer, intent(in),target :: el1,el2
INTEGER, INTENT(in),TARGET :: el1,el2
END FUNCTION compare_function
END INTERFACE
LOGICAL, OPTIONAL, INTENT(in) :: insert_equals
@ -1463,7 +1477,7 @@ END SUBROUTINE cp_sll_int_ptr_insert_ordered2
FUNCTION cp_sll_int_ptr_contains(sll,el,ordered,error) RESULT(res)
LOGICAL ::res
TYPE(cp_sll_int_ptr_type), POINTER :: sll
integer, intent(in),target :: el
INTEGER, INTENT(in),TARGET :: el
LOGICAL, INTENT(in), OPTIONAL :: ordered
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
@ -1471,7 +1485,7 @@ FUNCTION cp_sll_int_ptr_contains(sll,el,ordered,error) RESULT(res)
CHARACTER(len=*), PARAMETER :: routineN='cp_sll_int_ptr_contains',&
routineP=moduleN//':'//routineN
TYPE(cp_sll_int_ptr_type), POINTER :: iter
integer, pointer :: el_att
INTEGER, POINTER :: el_att
failure=.FALSE.; ord=.FALSE.
res=.FALSE.
@ -1530,12 +1544,12 @@ FUNCTION cp_sll_int_ptr_contains2(sll,el,compare_function,ordered,error)&
RESULT(res)
LOGICAL ::res
TYPE(cp_sll_int_ptr_type), POINTER :: sll
integer, intent(in),target :: el
INTEGER, INTENT(in),TARGET :: el
INTERFACE
FUNCTION compare_function(el1,el2)
USE cp_array_i_utils, ONLY: cp_i_write
INTEGER :: compare_function
integer, intent(in),target :: el1,el2
INTEGER, INTENT(in),TARGET :: el1,el2
END FUNCTION compare_function
END INTERFACE
LOGICAL, INTENT(in), OPTIONAL :: ordered
@ -1546,7 +1560,7 @@ FUNCTION cp_sll_int_ptr_contains2(sll,el,compare_function,ordered,error)&
CHARACTER(len=*), PARAMETER :: routineN='cp_sll_int_ptr_contains2',&
routineP=moduleN//':'//routineN
TYPE(cp_sll_int_ptr_type), POINTER :: iter
integer, pointer :: el_att
INTEGER, POINTER :: el_att
failure=.FALSE.
res=.FALSE.
@ -1576,23 +1590,23 @@ END FUNCTION cp_sll_int_ptr_contains2
! files are almost the same (multi-line use change it a bit)
! [template(defines,nametype1,type1,type1in,type1out,type1arrayEl,arrayEl,array=,=,USE,write_el,lessQ,equalQ)]
! ARGS:
! = = "=>"
! USE = "USE cp_array_i_utils, ONLY: cp_i_write"
! nametype1 = "int_ptr"
! array= = "="
! type1 = "integer, pointer"
! write_el = "cp_i_write"
! type1in = "integer, intent(in),target"
! arrayEl = ""
! equalQ = "CP_SLL_I_EQUAL_Q"
! type1out = "integer, pointer"
! defines =
! "#define CP_SLL_I_LESS_Q(el1,el2) ( el1 < el2 )
! #define CP_SLL_I_EQUAL_Q(el1,el2) ( el1 == el2 )
! #define PW_WRITE_UNIMPLEMENTED(el, unit, err)
! "
! = = "=>"
! equalQ = "CP_SLL_I_EQUAL_Q"
! lessQ = "CP_SLL_I_LESS_Q"
! nametype1 = "int_ptr"
! type1 = "integer, pointer"
! type1arrayEl = "integer"
! type1in = "integer, intent(in),target"
! type1out = "integer, pointer"
! write_el = "cp_i_write"
END MODULE cp_linked_list_int_ptr

14
src/cp_log_handling.F
View file

@ -289,7 +289,7 @@ CONTAINS
IF (.NOT. default_logger_initialized) THEN
CALL stop_program("cp_log_handling:cp_get_default_logger",&
"default logger not yet initialized (call cp_init_default_logger")
"default logger not yet initialized (CALL cp_init_default_logger")
END IF
IF (.NOT.ASSOCIATED(cp_default_logger)) THEN
CALL stop_program("cp_log_handling:cp_get_default_logger",&
@ -385,7 +385,7 @@ CONTAINS
LOGICAL :: exists
ALLOCATE(logger, stat=stat)
IF (stat/=0) CALL stop_program(routineP,"could not allocate a logger")
IF (stat/=0) CALL stop_program(routineP,"could not ALLOCATE a logger")
NULLIFY(logger%para_env,logger%print_keys)
logger%ref_count=1
@ -483,7 +483,7 @@ CONTAINS
END IF
END IF
! first global log to safely b-cast global unitnr
stat=cp_logger_get_default_unit_nr(logger, local=.false.)
stat=cp_logger_get_default_unit_nr(logger, local=.FALSE.)
! it would also be possible (if you don't care about printing a note)
! CALL cp_logger_log(logger,level=cp_note_level,&
! fromWhere=routineP, message="global logging activated",&
@ -949,7 +949,7 @@ CONTAINS
PRINT *," WARNING ", routineP, " overwriting file ",filename
END IF
CALL open_file(TRIM(filename),file_status="unknown",&
file_action="write",&
file_action="WRITE",&
unit_number=lggr%default_global_unit_nr)
END IF
! bcast could be dangerous if called only in source processor
@ -967,7 +967,7 @@ CONTAINS
PRINT *," WARNING ", routineP, " overwriting file ",filename
END IF
CALL open_file(TRIM(filename),file_status="unknown",&
file_action="write",&
file_action="WRITE",&
unit_number=lggr%default_local_unit_nr)
CALL m_getpid(pid)
CALL m_hostnm(host_name)
@ -979,7 +979,7 @@ CONTAINS
' **** pid=',pid,' host=',host_name
END IF
IF (iostat /= 0) THEN
PRINT *," Error trying to write to the local logger."
PRINT *," Error trying to WRITE to the local logger."
PRINT *," mpi_id=",lggr%para_env%mepos,&
" mpi_communicator=",lggr%para_env%group,&
" pid=",pid,'host=',host_name
@ -1030,7 +1030,7 @@ CONTAINS
CALL mp_comm_free(para_env%group)
END IF
DEALLOCATE(para_env,stat=stat)
IF(stat/=0)PRINT *,routineP," WARNING para_env deallocate stat=",stat
IF(stat/=0)PRINT *,routineP," WARNING para_env DEALLOCATE stat=",stat
END IF
END IF
NULLIFY(para_env)

1092
src/cp_matrix_utils.F
View file

File diff suppressed because it is too large Load diff

27
src/cp_output_handling.F
View file

@ -34,14 +34,25 @@
!! SOURCE
!*****************************************************************************
MODULE cp_output_handling
USE cp_log_handling, ONLY: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log,&
cp_logger_get_default_unit_nr, cp_logger_type
USE cp_error_handling, ONLY: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
USE kinds, ONLY: wp=>dp
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE kinds, ONLY: wp=>dp
IMPLICIT NONE
PRIVATE

44
src/cp_para_types.F
View file

@ -26,15 +26,15 @@
!!
!! SOURCE
!****************************************************************************
module cp_para_types
use kinds, only: wp=>dp
implicit none
private
MODULE cp_para_types
USE kinds, ONLY: wp=>dp
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character(len=*), private, parameter :: moduleN='cp_para_types'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='cp_para_types'
public :: cp_para_env_type, cp_blacs_env_type
PUBLIC :: cp_para_env_type, cp_blacs_env_type
!***
!****************************************************************************
@ -68,10 +68,10 @@ module cp_para_types
!!
!! SOURCE
!***************************************************************************
type cp_para_env_type
logical :: owns_group
integer :: mepos, group, source, num_pe, ref_count
end type cp_para_env_type
TYPE cp_para_env_type
LOGICAL :: owns_group
INTEGER :: mepos, group, source, num_pe, ref_count
END TYPE cp_para_env_type
!!***
!****************************************************************************
@ -105,11 +105,11 @@ module cp_para_types
!!
!! SOURCE
!***************************************************************************
type cp_para_cart_type
logical :: owns_group
integer, dimension(:), pointer :: mepos, source, num_pe
integer :: group, kind, ref_count
end type cp_para_cart_type
TYPE cp_para_cart_type
LOGICAL :: owns_group
INTEGER, DIMENSION(:), POINTER :: mepos, source, num_pe
INTEGER :: group, kind, ref_count
END TYPE cp_para_cart_type
!!***
!****************************************************************************
@ -147,12 +147,12 @@ module cp_para_types
!!
!! SOURCE
!***************************************************************************
type cp_blacs_env_type
logical :: owns_group
integer, dimension(2) :: mepos, source, num_pe
integer :: group, my_pid, n_pid, ref_count
end type cp_blacs_env_type
TYPE cp_blacs_env_type
LOGICAL :: owns_group
INTEGER, DIMENSION(2) :: mepos, source, num_pe
INTEGER :: group, my_pid, n_pid, ref_count
END TYPE cp_blacs_env_type
!!***
!****************************************************************************
end module cp_para_types
END MODULE cp_para_types

139
src/cp_sll_int_ptr_tests.F
View file

@ -26,29 +26,40 @@
!!
!! SOURCE
!*****************************************************************************
module cp_sll_int_ptr_tests
use cp_log_handling, only: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log,&
cp_logger_get_default_unit_nr
use cp_error_handling, only: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
use kinds, only: wp=>dp
use global_types, only: global_environment_type
use cp_array_utils, only: cp_output
use cp_linked_list_int_ptr
implicit none
private
MODULE cp_sll_int_ptr_tests
USE cp_array_utils, ONLY: cp_output
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_linked_list_int_ptr
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character, private, parameter :: moduleN='cp_sll_int_ptr_tests'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER, PRIVATE, PARAMETER :: moduleN='cp_sll_int_ptr_tests'
public :: cp_test_int_ptr_sll
PUBLIC :: cp_test_int_ptr_sll
!!***
!****************************************************************************
contains
CONTAINS
!!****f* cp_sll_int_ptr_tests/cp_test_int_ptr_sll [1.0] *
!!
@ -82,71 +93,71 @@ contains
!!
!! SOURCE
!***************************************************************************
function cp_test_int_ptr_sll(glob_env, error) result(res)
logical :: res
type(global_environment_type), target :: glob_env
type(cp_error_type), optional, intent(inout) :: error
FUNCTION cp_test_int_ptr_sll(glob_env, error) RESULT(res)
LOGICAL :: res
TYPE(global_environment_type), TARGET :: glob_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_test_int_ptr_sll',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_test_int_ptr_sll',&
routineP=moduleN//routineN
integer, parameter :: n=6
integer, dimension(n) :: array
integer :: i
type(cp_sll_int_ptr_type), pointer :: reverseList, iterator
integer, pointer :: el
failure=.false.
nullify(reverseList,iterator)
INTEGER, PARAMETER :: n=6
INTEGER, DIMENSION(n) :: array
INTEGER :: i
TYPE(cp_sll_int_ptr_type), POINTER :: reverseList, iterator
INTEGER, POINTER :: el
failure=.FALSE.
NULLIFY(reverseList,iterator)
forall (i=1:size(array)) array(i)=i*i
call cp_create(reverseList,error=error)
do i=1,size(array)
call cp_insert(reverseList,array(i),error=error)
end do
FORALL (i=1:SIZE(array)) array(i)=i*i
CALL cp_create(reverseList,error=error)
DO i=1,SIZE(array)
CALL cp_insert(reverseList,array(i),error=error)
END DO
CPAssert(cp_get_length(reverseList)==n,cp_warning_level,routineP,error,failure)
if (.not. failure) then
IF (.NOT. failure) THEN
iterator => reverseList
do i=1,size(array)
call cp_assert(cp_get_element_at(reverseList,i)==array(n-i+1),&
DO i=1,SIZE(array)
CALL cp_assert(cp_get_element_at(reverseList,i)==array(n-i+1),&
cp_warning_level,cp_assertion_failed,routineP,&
"reverse list ("//cp_to_string(i)//")="//cp_to_string(&
cp_get_element_at(reverseList,i))//" /= "//cp_to_string(array(n-i+1))&
//"array("//cp_to_string(n-i+1)//") in "//&
CPSourceFileRef,&
error,failure)
if (.not.cp_next(iterator,el_att=el,error=error)) then
CPPrecondition(.false.,cp_warning_level,routineP,error,failure)
end if
if (.not.failure) then
call cp_assert(el==array(n-i+1),&
IF (.not.cp_next(iterator,el_att=el,error=error)) THEN
CPPrecondition(.FALSE.,cp_warning_level,routineP,error,failure)
END IF
IF (.not.failure) THEN
CALL cp_assert(el==array(n-i+1),&
cp_warning_level,cp_assertion_failed,routineP,&
"iterator /= array(n-i+1) with i="//cp_to_string(i)//&
" in "//&
CPSourceFileRef,&
error,failure)
end if
end do
END IF
END DO
CPAssert(.not.cp_next(iterator),cp_warning_level,routineP,error,failure)
end if
call cp_dealloc(reverseList,error=error)
if (debug_this_module.and.cp_debug) then
if (failure) then
call cp_error_message(cp_warning_level, routineP,&
END IF
CALL cp_dealloc(reverseList,error=error)
IF (debug_this_module.and.cp_debug) THEN
IF (failure) THEN
CALL cp_error_message(cp_warning_level, routineP,&
"int_ptr single linked list tests: tests FAILED",error)
iterator=>reverseList
print *,"list="
do
if (.not.cp_next(iterator,el_att=el,error=error)) exit
print *, " ",el,","
end do
print *,"array=",array
else
call cp_error_message(cp_warning_level, routineP,&
PRINT *,"list="
DO
IF (.not.cp_next(iterator,el_att=el,error=error)) EXIT
PRINT *, " ",el,","
END DO
PRINT *,"array=",array
ELSE
CALL cp_error_message(cp_warning_level, routineP,&
"int_ptr single linked list tests: SUCESS",error)
end if
end if
END IF
END IF
res=.not.failure
end function cp_test_int_ptr_sll
END FUNCTION cp_test_int_ptr_sll
!!***
!***************************************************************************
@ -154,9 +165,9 @@ end function cp_test_int_ptr_sll
! files are almost the same
! [template(el_type,plain_el_type,name_el_type)]
! ARGS:
! el_type = "integer, pointer"
! name_el_type = "int_ptr"
! plain_el_type = "integer"
! el_type = "integer, pointer"
end module cp_sll_int_ptr_tests
END MODULE cp_sll_int_ptr_tests

139
src/cp_sll_int_tests.F
View file

@ -26,29 +26,40 @@
!!
!! SOURCE
!*****************************************************************************
module cp_sll_int_tests
use cp_log_handling, only: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log,&
cp_logger_get_default_unit_nr
use cp_error_handling, only: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
use kinds, only: wp=>dp
use global_types, only: global_environment_type
use cp_array_utils, only: cp_output
use cp_linked_list_int
implicit none
private
MODULE cp_sll_int_tests
USE cp_array_utils, ONLY: cp_output
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_linked_list_int
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character, private, parameter :: moduleN='cp_sll_int_tests'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER, PRIVATE, PARAMETER :: moduleN='cp_sll_int_tests'
public :: cp_test_int_sll
PUBLIC :: cp_test_int_sll
!!***
!****************************************************************************
contains
CONTAINS
!!****f* cp_sll_int_tests/cp_test_int_sll [1.0] *
!!
@ -82,71 +93,71 @@ contains
!!
!! SOURCE
!***************************************************************************
function cp_test_int_sll(glob_env, error) result(res)
logical :: res
type(global_environment_type), target :: glob_env
type(cp_error_type), optional, intent(inout) :: error
FUNCTION cp_test_int_sll(glob_env, error) RESULT(res)
LOGICAL :: res
TYPE(global_environment_type), TARGET :: glob_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_test_int_sll',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_test_int_sll',&
routineP=moduleN//routineN
integer, parameter :: n=6
integer, dimension(n) :: array
integer :: i
type(cp_sll_int_type), pointer :: reverseList, iterator
integer :: el
failure=.false.
nullify(reverseList,iterator)
INTEGER, PARAMETER :: n=6
INTEGER, DIMENSION(n) :: array
INTEGER :: i
TYPE(cp_sll_int_type), POINTER :: reverseList, iterator
INTEGER :: el
failure=.FALSE.
NULLIFY(reverseList,iterator)
forall (i=1:size(array)) array(i)=i*i
call cp_create(reverseList,error=error)
do i=1,size(array)
call cp_insert(reverseList,array(i),error=error)
end do
FORALL (i=1:SIZE(array)) array(i)=i*i
CALL cp_create(reverseList,error=error)
DO i=1,SIZE(array)
CALL cp_insert(reverseList,array(i),error=error)
END DO
CPAssert(cp_get_length(reverseList)==n,cp_warning_level,routineP,error,failure)
if (.not. failure) then
IF (.NOT. failure) THEN
iterator => reverseList
do i=1,size(array)
call cp_assert(cp_get_element_at(reverseList,i)==array(n-i+1),&
DO i=1,SIZE(array)
CALL cp_assert(cp_get_element_at(reverseList,i)==array(n-i+1),&
cp_warning_level,cp_assertion_failed,routineP,&
"reverse list ("//cp_to_string(i)//")="//cp_to_string(&
cp_get_element_at(reverseList,i))//" /= "//cp_to_string(array(n-i+1))&
//"array("//cp_to_string(n-i+1)//") in "//&
CPSourceFileRef,&
error,failure)
if (.not.cp_next(iterator,el_att=el,error=error)) then
CPPrecondition(.false.,cp_warning_level,routineP,error,failure)
end if
if (.not.failure) then
call cp_assert(el==array(n-i+1),&
IF (.not.cp_next(iterator,el_att=el,error=error)) THEN
CPPrecondition(.FALSE.,cp_warning_level,routineP,error,failure)
END IF
IF (.not.failure) THEN
CALL cp_assert(el==array(n-i+1),&
cp_warning_level,cp_assertion_failed,routineP,&
"iterator /= array(n-i+1) with i="//cp_to_string(i)//&
" in "//&
CPSourceFileRef,&
error,failure)
end if
end do
END IF
END DO
CPAssert(.not.cp_next(iterator),cp_warning_level,routineP,error,failure)
end if
call cp_dealloc(reverseList,error=error)
if (debug_this_module.and.cp_debug) then
if (failure) then
call cp_error_message(cp_warning_level, routineP,&
END IF
CALL cp_dealloc(reverseList,error=error)
IF (debug_this_module.and.cp_debug) THEN
IF (failure) THEN
CALL cp_error_message(cp_warning_level, routineP,&
"int single linked list tests: tests FAILED",error)
iterator=>reverseList
print *,"list="
do
if (.not.cp_next(iterator,el_att=el,error=error)) exit
print *, " ",el,","
end do
print *,"array=",array
else
call cp_error_message(cp_warning_level, routineP,&
PRINT *,"list="
DO
IF (.not.cp_next(iterator,el_att=el,error=error)) EXIT
PRINT *, " ",el,","
END DO
PRINT *,"array=",array
ELSE
CALL cp_error_message(cp_warning_level, routineP,&
"int single linked list tests: SUCESS",error)
end if
end if
END IF
END IF
res=.not.failure
end function cp_test_int_sll
END FUNCTION cp_test_int_sll
!!***
!***************************************************************************
@ -154,9 +165,9 @@ end function cp_test_int_sll
! files are almost the same
! [template(el_type,plain_el_type,name_el_type)]
! ARGS:
! el_type = "integer"
! name_el_type = "int"
! plain_el_type = "integer"
! el_type = "integer"
end module cp_sll_int_tests
END MODULE cp_sll_int_tests

244
src/cp_sp_iterators.F
View file

@ -24,52 +24,64 @@
!!
!! SOURCE
!****************************************************************************
module cp_sp_iterators
use cp_log_handling, only: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log,&
cp_logger_get_default_unit_nr, cp_logger_type
use cp_error_handling, only: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
use kinds, only: wp=>dp
use global_types, only: global_environment_type
use timings, only: timeset, timestop
implicit none
private
MODULE cp_sp_iterators
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character(len=*), private, parameter :: moduleN='cp_sp_iterators'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='cp_sp_iterators'
public :: cp_sp_local_b_iter_type, cp_sp_owned_b_iter_type,&
PUBLIC :: cp_sp_local_b_iter_type, cp_sp_owned_b_iter_type,&
cp_sp_cached_b_iter_type, cp_sp_g_block_iterator
public :: cp_init, cp_dealloc_ref, cp_next
public :: cp_sp_local_b_iter_init, cp_sp_local_b_iter_dealloc_ref,&
PUBLIC :: cp_init, cp_dealloc_ref, cp_next
PUBLIC :: cp_sp_local_b_iter_init, cp_sp_local_b_iter_dealloc_ref,&
cp_sp_local_b_iter_next, cp_sp_owned_b_iter_init,&
cp_sp_owned_b_iter_dealloc_ref, cp_sp_cached_b_iter_init,&
cp_sp_owned_b_iter_dealloc_ref
interface cp_init
module procedure cp_sp_local_b_iter_init
end interface
interface cp_dealloc_ref
module procedure cp_sp_local_b_iter_dealloc_ref
end interface
interface cp_next
module procedure cp_sp_local_b_iter_next
end interface
interface cp_init
module procedure cp_sp_owned_b_iter_init
end interface
interface cp_dealloc_ref
module procedure cp_sp_owned_b_iter_dealloc_ref
end interface
interface cp_init
module procedure cp_sp_cached_b_iter_init
end interface
interface cp_dealloc_ref
module procedure cp_sp_owned_b_iter_dealloc_ref
end interface
INTERFACE cp_init
MODULE PROCEDURE cp_sp_local_b_iter_init
END INTERFACE
INTERFACE cp_dealloc_ref
MODULE PROCEDURE cp_sp_local_b_iter_dealloc_ref
END INTERFACE
INTERFACE cp_next
MODULE PROCEDURE cp_sp_local_b_iter_next
END INTERFACE
INTERFACE cp_init
MODULE PROCEDURE cp_sp_owned_b_iter_init
END INTERFACE
INTERFACE cp_dealloc_ref
MODULE PROCEDURE cp_sp_owned_b_iter_dealloc_ref
END INTERFACE
INTERFACE cp_init
MODULE PROCEDURE cp_sp_cached_b_iter_init
END INTERFACE
INTERFACE cp_dealloc_ref
MODULE PROCEDURE cp_sp_owned_b_iter_dealloc_ref
END INTERFACE
!***
!****************************************************************************
@ -96,11 +108,11 @@ module cp_sp_iterators
!!
!! SOURCE
!***************************************************************************
type cp_sp_local_b_iter_type
logical :: initialized, all_blocks
type(cp_block_matrix_type), pointer :: matrix
type(cp_matrix_block_iterator) :: iterator
end type cp_sp_local_b_iter_type
TYPE cp_sp_local_b_iter_type
LOGICAL :: initialized, all_blocks
TYPE(cp_block_matrix_type), POINTER :: matrix
TYPE(cp_matrix_block_iterator) :: iterator
END TYPE cp_sp_local_b_iter_type
!!***
!****************************************************************************
@ -127,9 +139,9 @@ module cp_sp_iterators
!!
!! SOURCE
!***************************************************************************
type cp_sp_owned_b_iter_type
type(cp_sp_local_b_iter_type), pointer :: local_iterator
end type cp_sp_owned_b_iter_type
TYPE cp_sp_owned_b_iter_type
TYPE(cp_sp_local_b_iter_type), POINTER :: local_iterator
END TYPE cp_sp_owned_b_iter_type
!!***
!****************************************************************************
@ -156,9 +168,9 @@ module cp_sp_iterators
!!
!! SOURCE
!***************************************************************************
type cp_sp_cached_b_iter_type
type(cp_sp_local_b_iter_type), pointer :: local_iterator
end type cp_sp_cached_b_iter_type
TYPE cp_sp_cached_b_iter_type
TYPE(cp_sp_local_b_iter_type), POINTER :: local_iterator
END TYPE cp_sp_cached_b_iter_type
!!***
!****************************************************************************
@ -185,15 +197,15 @@ module cp_sp_iterators
!!
!! SOURCE
!***************************************************************************
type cp_sp_g_block_iterator
logical :: initialized
type(cp_block_matrix_type) :: matrix
integer :: i,j
end type cp_sp_g_block_iterator
TYPE cp_sp_g_block_iterator
LOGICAL :: initialized
TYPE(cp_block_matrix_type) :: matrix
INTEGER :: i,j
END TYPE cp_sp_g_block_iterator
!!***
!****************************************************************************
contains
CONTAINS
!=========== block iterators ============
!==== local block iterator ====
@ -224,20 +236,20 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_sp_local_b_iter_init(iterator,matrix,error)
type(cp_sp_owned_b_iter_type), intent(out) :: iterator
type(cp_block_matrix_type), intent(in), target :: matrix
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_sp_local_b_iter_init(iterator,matrix,error)
TYPE(cp_sp_owned_b_iter_type), INTENT(out) :: iterator
TYPE(cp_block_matrix_type), INTENT(in), TARGET :: matrix
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_sp_local_b_iter_init',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_sp_local_b_iter_init',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
if (.not. failure) then
IF (.NOT. failure) THEN
end if
end subroutine cp_sp_local_b_iter_init
END IF
END SUBROUTINE cp_sp_local_b_iter_init
!***************************************************************************
!!****f* cp_sp_local_b_iter_dealloc_ref [1.0] *
@ -264,19 +276,19 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_sp_local_b_iter_dealloc_ref(iterator, error)
type(cp_sp_owned_b_iter_dealloc_ref), intent(inout) :: iterator
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_sp_local_b_iter_dealloc_ref(iterator, error)
TYPE(cp_sp_owned_b_iter_dealloc_ref), INTENT(inout) :: iterator
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_sp_local_b_iter_dealloc_ref',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_sp_local_b_iter_dealloc_ref',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
if (.not. failure) then
IF (.NOT. failure) THEN
end if
end subroutine cp_sp_local_b_iter_dealloc_ref
END IF
END SUBROUTINE cp_sp_local_b_iter_dealloc_ref
!***************************************************************************
!!****f* cp_sp_iterators/cp_sp_local_b_iter_next [1.0] *
@ -314,24 +326,24 @@ contains
!! none
!!
!!*** **********************************************************************
function cp_sp_local_b_iter_next(iterator, block_row, block_col, block_val,&
trans_to_do, local_scatch, owned, local_copy,error)result(res)
type(cp_sp_local_b_iter_next), intent(inout) :: iterator
integer, intent(out), optional :: block_row, block_col
real(kind=wp), dimension(:,:), pointer, optional :: block_val
character(len=1), intent(out), optional :: trans_to_do
logical, intent(out), optional :: local_scratch, owned, local_copy
type(cp_error_type), optional, intent(inout) :: error
FUNCTION cp_sp_local_b_iter_next(iterator, block_row, block_col, block_val,&
trans_to_do, local_scatch, owned, local_copy,error)RESULT(res)
TYPE(cp_sp_local_b_iter_next), INTENT(inout) :: iterator
INTEGER, INTENT(out), OPTIONAL :: block_row, block_col
REAL(kind=wp), DIMENSION(:,:), POINTER, OPTIONAL :: block_val
CHARACTER(len=1), INTENT(out), OPTIONAL :: trans_to_do
LOGICAL, INTENT(out), OPTIONAL :: local_scratch, owned, local_copy
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_sp_local_b_iter_next',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_sp_local_b_iter_next',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
if (.not. failure) then
IF (.NOT. failure) THEN
end if
end function cp_sp_local_b_iter_next
END IF
END FUNCTION cp_sp_local_b_iter_next
!***************************************************************************
!=== owned blocks iterator ===
@ -361,17 +373,17 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_sp_owned_b_iter_init(iterator,matrix,error)
type(cp_sp_owned_b_iter_type), intent(out) :: iterator
type(cp_block_matrix_type), intent(in), target :: matrix
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_sp_owned_b_iter_init(iterator,matrix,error)
TYPE(cp_sp_owned_b_iter_type), INTENT(out) :: iterator
TYPE(cp_block_matrix_type), INTENT(in), TARGET :: matrix
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
character(len=*), parameter :: routineN='cp_sp_owned_b_iter_init',&
CHARACTER(len=*), PARAMETER :: routineN='cp_sp_owned_b_iter_init',&
routineP=moduleN//':'//routineN
call cp_sp_local_b_iter_init(iterator%local_iterator,&
CALL cp_sp_local_b_iter_init(iterator%local_iterator,&
matrix=matrix,error=error)
end subroutine cp_sp_owned_b_iter_init
END SUBROUTINE cp_sp_owned_b_iter_init
!***************************************************************************
!!****f* cp_sp_owned_b_iter_dealloc_ref [1.0] *
@ -398,16 +410,16 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_sp_owned_b_iter_dealloc_ref(iterator, error)
type(cp_sp_owned_b_iter_dealloc_ref), intent(inout) :: iterator
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_sp_owned_b_iter_dealloc_ref(iterator, error)
TYPE(cp_sp_owned_b_iter_dealloc_ref), INTENT(inout) :: iterator
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
character(len=*), parameter :: routineN='cp_sp_owned_b_iter_dealloc_ref',&
CHARACTER(len=*), PARAMETER :: routineN='cp_sp_owned_b_iter_dealloc_ref',&
routineP=moduleN//':'//routineN
call cp_sp_local_b_iter_dealloc_ref(iterator%local_iterator,&
CALL cp_sp_local_b_iter_dealloc_ref(iterator%local_iterator,&
error=error)
end subroutine cp_sp_owned_b_iter_dealloc_ref
END SUBROUTINE cp_sp_owned_b_iter_dealloc_ref
!***************************************************************************
@ -438,17 +450,17 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_sp_cached_b_iter_init(iterator,matrix,error)
type(cp_sp_cached_b_iter_type), intent(out) :: iterator
type(cp_block_matrix_type), intent(in), target :: matrix
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_sp_cached_b_iter_init(iterator,matrix,error)
TYPE(cp_sp_cached_b_iter_type), INTENT(out) :: iterator
TYPE(cp_block_matrix_type), INTENT(in), TARGET :: matrix
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
character(len=*), parameter :: routineN='cp_sp_cached_b_iter_init',&
CHARACTER(len=*), PARAMETER :: routineN='cp_sp_cached_b_iter_init',&
routineP=moduleN//':'//routineN
call cp_sp_local_b_iter_init(iterator%local_iterator,&
CALL cp_sp_local_b_iter_init(iterator%local_iterator,&
matrix=matrix,error=error)
end subroutine cp_sp_cached_b_iter_init
END SUBROUTINE cp_sp_cached_b_iter_init
!***************************************************************************
@ -476,16 +488,16 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_sp_owned_b_iter_dealloc_ref(iterator, error)
type(cp_sp_owned_b_iter_dealloc_ref), intent(inout) :: iterator
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_sp_owned_b_iter_dealloc_ref(iterator, error)
TYPE(cp_sp_owned_b_iter_dealloc_ref), INTENT(inout) :: iterator
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
character(len=*), parameter :: routineN='cp_sp_owned_b_iter_dealloc_ref',&
CHARACTER(len=*), PARAMETER :: routineN='cp_sp_owned_b_iter_dealloc_ref',&
routineP=moduleN//':'//routineN
call cp_sp_local_b_iter_dealloc_ref(iterator%local_iterator,&
CALL cp_sp_local_b_iter_dealloc_ref(iterator%local_iterator,&
error=error)
end subroutine cp_sp_owned_b_iter_dealloc_ref
END SUBROUTINE cp_sp_owned_b_iter_dealloc_ref
!***************************************************************************
end module cp_sp_iterators
END MODULE cp_sp_iterators

486
src/pao_bas_projection_types.F
View file

@ -25,57 +25,65 @@
!!
!! SOURCE
!****************************************************************************
module pao_bas_projection_types
use cp_log_handling, only: cp_failure_level, cp_warning_level, cp_to_string
use cp_error_handling, only: cp_error_type, cp_assert, cp_debug
use kinds, only: wp=>dp
use global_types, only: global_environment_type
use timings, only: timeset, timestop
use cp_array_utils, only: cp_write
use cp_linked_list_int, only: cp_create, cp_insert, cp_dealloc,&
cp_sll_int_type, cp_next
implicit none
private
MODULE pao_bas_projection_types
USE cp_array_utils, ONLY: cp_write
USE cp_error_handling, ONLY: cp_assert,&
cp_debug,&
cp_error_type
USE cp_linked_list_int, ONLY: cp_create,&
cp_dealloc,&
cp_insert,&
cp_next,&
cp_sll_int_type
USE cp_log_handling, ONLY: cp_failure_level,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character(len=*), private, parameter :: moduleN='pao_bas_projection'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='pao_bas_projection'
public :: pao_bas_projection_type
public :: cp_create, cp_dealloc, cp_init, cp_dealloc_ref,&
PUBLIC :: pao_bas_projection_type
PUBLIC :: cp_create, cp_dealloc, cp_init, cp_dealloc_ref,&
cp_valid, cp_get, cp_get_proj_indexes, cp_get_non_proj_indexes,&
cp_write
public :: cp_proj_create, cp_proj_dealloc, cp_proj_init,&
PUBLIC :: cp_proj_create, cp_proj_dealloc, cp_proj_init,&
cp_proj_dealloc_ref, cp_proj_valid, cp_proj_get,&
cp_proj_get_proj_indexes, cp_proj_get_non_proj_indexes,&
cp_proj_write , cp_proj_init2, cp_proj_create2
interface cp_create
module procedure cp_proj_create , cp_proj_create2
end interface
interface cp_dealloc
module procedure cp_proj_dealloc
end interface
interface cp_init
module procedure cp_proj_init , cp_proj_init2
end interface
interface cp_dealloc_ref
module procedure cp_proj_dealloc_ref
end interface
interface cp_valid
module procedure cp_proj_valid
end interface
interface cp_get
module procedure cp_proj_get
end interface
interface cp_get_proj_indexes
module procedure cp_proj_get_proj_indexes
end interface
interface cp_get_non_proj_indexes
module procedure cp_proj_get_non_proj_indexes
end interface
interface cp_write
module procedure cp_proj_write
end interface
INTERFACE cp_create
MODULE PROCEDURE cp_proj_create , cp_proj_create2
END INTERFACE
INTERFACE cp_dealloc
MODULE PROCEDURE cp_proj_dealloc
END INTERFACE
INTERFACE cp_init
MODULE PROCEDURE cp_proj_init , cp_proj_init2
END INTERFACE
INTERFACE cp_dealloc_ref
MODULE PROCEDURE cp_proj_dealloc_ref
END INTERFACE
INTERFACE cp_valid
MODULE PROCEDURE cp_proj_valid
END INTERFACE
INTERFACE cp_get
MODULE PROCEDURE cp_proj_get
END INTERFACE
INTERFACE cp_get_proj_indexes
MODULE PROCEDURE cp_proj_get_proj_indexes
END INTERFACE
INTERFACE cp_get_non_proj_indexes
MODULE PROCEDURE cp_proj_get_non_proj_indexes
END INTERFACE
INTERFACE cp_write
MODULE PROCEDURE cp_proj_write
END INTERFACE
!!***
!****************************************************************************
@ -107,16 +115,16 @@ module pao_bas_projection_types
!!
!! SOURCE
!***************************************************************************
type pao_bas_projection_type
private
logical :: initialized
integer, dimension(:), pointer :: proj_indexes
integer, dimension(:), pointer :: non_proj_indexes
end type pao_bas_projection_type
TYPE pao_bas_projection_type
PRIVATE
LOGICAL :: initialized
INTEGER, DIMENSION(:), POINTER :: proj_indexes
INTEGER, DIMENSION(:), POINTER :: non_proj_indexes
END TYPE pao_bas_projection_type
!!***
!****************************************************************************
contains
CONTAINS
!!****f* pao_bas_projection/cp_proj_create [1.0] *
!!
@ -147,25 +155,25 @@ contains
!! 4.2002 created [fawzi]
!!
!!*** **********************************************************************
subroutine cp_proj_create(proj, proj_indexes, size_full_bas, &
SUBROUTINE cp_proj_create(proj, proj_indexes, size_full_bas, &
error)
type(pao_bas_projection_type), pointer :: proj
integer, dimension(:), intent(in) ::proj_indexes
integer, intent(in) :: size_full_bas
type(cp_error_type), optional, intent(inout) :: error
TYPE(pao_bas_projection_type), POINTER :: proj
INTEGER, DIMENSION(:), INTENT(in) ::proj_indexes
INTEGER, INTENT(in) :: size_full_bas
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
integer :: stat
character(len=*), parameter :: routineN='cp_proj_create',&
LOGICAL :: failure
INTEGER :: stat
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_create',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
allocate(proj,stat=stat)
ALLOCATE(proj,stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
if (.not.failure) then
call cp_proj_init(proj, proj_indexes, size_full_bas, error)
end if
end subroutine cp_proj_create
IF (.not.failure) THEN
CALL cp_proj_init(proj, proj_indexes, size_full_bas, error)
END IF
END SUBROUTINE cp_proj_create
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_create2 [1.0] *
@ -197,25 +205,25 @@ end subroutine cp_proj_create
!! 4.2002 created [fawzi]
!!
!!*** **********************************************************************
subroutine cp_proj_create2(proj, proj_indexes, size_full_bas, &
SUBROUTINE cp_proj_create2(proj, proj_indexes, size_full_bas, &
error)
type(pao_bas_projection_type), pointer :: proj
type(cp_sll_int_type), pointer ::proj_indexes
integer, intent(in) :: size_full_bas
type(cp_error_type), optional, intent(inout) :: error
TYPE(pao_bas_projection_type), POINTER :: proj
TYPE(cp_sll_int_type), POINTER ::proj_indexes
INTEGER, INTENT(in) :: size_full_bas
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
integer :: stat
character(len=*), parameter :: routineN='cp_proj_create2',&
LOGICAL :: failure
INTEGER :: stat
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_create2',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
allocate(proj,stat=stat)
ALLOCATE(proj,stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
if (.not.failure) then
call cp_proj_init2(proj, proj_indexes, size_full_bas, error)
end if
end subroutine cp_proj_create2
IF (.not.failure) THEN
CALL cp_proj_init2(proj, proj_indexes, size_full_bas, error)
END IF
END SUBROUTINE cp_proj_create2
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_dealloc [1.0] *
@ -247,22 +255,22 @@ end subroutine cp_proj_create2
!! 4.2002 created [fawzi]
!!
!!*** **********************************************************************
subroutine cp_proj_dealloc(proj,error)
type(pao_bas_projection_type), pointer :: proj
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_proj_dealloc(proj,error)
TYPE(pao_bas_projection_type), POINTER :: proj
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
integer :: stat
character(len=*), parameter :: routineN='cp_proj_dealloc',&
LOGICAL :: failure
INTEGER :: stat
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_dealloc',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
if (associated(proj)) then
call cp_proj_dealloc_ref(proj,error=error)
deallocate(proj,stat=stat)
IF (ASSOCIATED(proj)) THEN
CALL cp_proj_dealloc_ref(proj,error=error)
DEALLOCATE(proj,stat=stat)
CPPostcondition(stat==0,cp_warning_level,routineP,error,failure)
end if
end subroutine cp_proj_dealloc
END IF
END SUBROUTINE cp_proj_dealloc
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_init [1.0] *
@ -300,49 +308,49 @@ end subroutine cp_proj_dealloc
!! none
!!
!!*** **********************************************************************
subroutine cp_proj_init(proj, proj_indexes, size_full_bas, &
SUBROUTINE cp_proj_init(proj, proj_indexes, size_full_bas, &
error)
type(pao_bas_projection_type), intent(out) :: proj
integer, dimension(:), intent(in) ::proj_indexes
integer, intent(in) :: size_full_bas
type(cp_error_type), optional, intent(inout) :: error
TYPE(pao_bas_projection_type), INTENT(out) :: proj
INTEGER, DIMENSION(:), INTENT(in) ::proj_indexes
INTEGER, INTENT(in) :: size_full_bas
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure,found
integer :: stat, i, j, exc_pos
character(len=*), parameter :: routineN='cp_proj_init',&
LOGICAL :: failure,found
INTEGER :: stat, i, j, exc_pos
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_init',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
CPPrecondition(all(proj_indexes>0),cp_failure_level,routineP,error,failure)
CPPrecondition(size(proj_indexes)<=size_full_bas,cp_failure_level,routineP,error,failure)
allocate(proj%proj_indexes(size(proj_indexes)),&
proj%non_proj_indexes(size_full_bas-size(proj_indexes)), stat=stat)
CPPrecondition(ALL(proj_indexes>0),cp_failure_level,routineP,error,failure)
CPPrecondition(SIZE(proj_indexes)<=size_full_bas,cp_failure_level,routineP,error,failure)
ALLOCATE(proj%proj_indexes(SIZE(proj_indexes)),&
proj%non_proj_indexes(size_full_bas-SIZE(proj_indexes)), stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
!do i=2,size(proj_indexes)
! CPPrecondition(proj_indexes(i-1)<proj_indexes(i),cp_failure_level,routineP,error,failure)
!end do
if (.not.failure) then
IF (.not.failure) THEN
proj%proj_indexes=proj_indexes
exc_pos=0
do i=1,size_full_bas
found=.false.
do j=1,size(proj%proj_indexes)
if (i==proj%proj_indexes(j)) then
found=.true.
exit
end if
end do
if (.not.found) then
CPInvariant(exc_pos<size(proj%non_proj_indexes),cp_failure_level,routineP,error,failure)
if (.not.failure) then
DO i=1,size_full_bas
found=.FALSE.
DO j=1,SIZE(proj%proj_indexes)
IF (i==proj%proj_indexes(j)) THEN
found=.TRUE.
EXIT
END IF
END DO
IF (.not.found) THEN
CPInvariant(exc_pos<SIZE(proj%non_proj_indexes),cp_failure_level,routineP,error,failure)
IF (.not.failure) THEN
exc_pos=exc_pos+1
proj%non_proj_indexes(exc_pos)=i
end if
end if
end do
proj%initialized=.true.
end if
end subroutine cp_proj_init
END IF
END IF
END DO
proj%initialized=.TRUE.
END IF
END SUBROUTINE cp_proj_init
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_init2 [1.0] *
@ -380,58 +388,58 @@ end subroutine cp_proj_dealloc
!! none
!!
!!*** **********************************************************************
subroutine cp_proj_init2(proj, proj_indexes, size_full_bas, &
SUBROUTINE cp_proj_init2(proj, proj_indexes, size_full_bas, &
error)
type(pao_bas_projection_type), intent(out) :: proj
type(cp_sll_int_type), pointer ::proj_indexes
integer, intent(in) :: size_full_bas
type(cp_error_type), optional, intent(inout) :: error
TYPE(pao_bas_projection_type), INTENT(out) :: proj
TYPE(cp_sll_int_type), POINTER ::proj_indexes
INTEGER, INTENT(in) :: size_full_bas
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure,found
integer :: stat, size_min_bas, i, j, exc_pos, el_att
character(len=*), parameter :: routineN='cp_proj_init2',&
LOGICAL :: failure,found
INTEGER :: stat, size_min_bas, i, j, exc_pos, el_att
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_init2',&
routineP=moduleN//':'//routineN
type(cp_sll_int_type), pointer :: iterator
failure=.false.
TYPE(cp_sll_int_type), POINTER :: iterator
failure=.FALSE.
iterator => proj_indexes
size_min_bas=0
do
if (.not.cp_next(iterator, el_att=el_att, error=error)) exit
DO
IF (.not.cp_next(iterator, el_att=el_att, error=error)) EXIT
size_min_bas=size_min_bas+1
CPPrecondition(el_att>0,cp_failure_level,routineP,error,failure)
end do
END DO
CPPrecondition(size_min_bas<=size_full_bas,cp_failure_level,routineP,error,failure)
CPPreconditionNoFail(size_min_bas>0,cp_warning_level,routineP,error)
allocate(proj%proj_indexes(size_min_bas),&
ALLOCATE(proj%proj_indexes(size_min_bas),&
proj%non_proj_indexes(size_full_bas-size_min_bas), stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
if (.not.failure) then
IF (.not.failure) THEN
iterator => proj_indexes
do i=1,size_min_bas
if (.not.cp_next(iterator, el_att=el_att, error=error)) exit
DO i=1,size_min_bas
IF (.not.cp_next(iterator, el_att=el_att, error=error)) EXIT
proj%proj_indexes(i)=el_att
end do
END DO
exc_pos=0
do i=1,size_full_bas
found=.false.
do j=1,size(proj%proj_indexes)
if (i==proj%proj_indexes(j)) then
found=.true.
exit
end if
end do
if (.not.found) then
CPInvariant(exc_pos<size(proj%non_proj_indexes),cp_failure_level,routineP,error,failure)
if (.not.failure) then
DO i=1,size_full_bas
found=.FALSE.
DO j=1,SIZE(proj%proj_indexes)
IF (i==proj%proj_indexes(j)) THEN
found=.TRUE.
EXIT
END IF
END DO
IF (.not.found) THEN
CPInvariant(exc_pos<SIZE(proj%non_proj_indexes),cp_failure_level,routineP,error,failure)
IF (.not.failure) THEN
exc_pos=exc_pos+1
proj%non_proj_indexes(exc_pos)=i
end if
end if
end do
proj%initialized=.true.
end if
end subroutine cp_proj_init2
END IF
END IF
END DO
proj%initialized=.TRUE.
END IF
END SUBROUTINE cp_proj_init2
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_dealloc_ref [1.0] *
@ -464,25 +472,25 @@ end subroutine cp_proj_dealloc
!! none
!!
!!*** **********************************************************************
subroutine cp_proj_dealloc_ref(proj, error)
type(pao_bas_projection_type), intent(inout) :: proj
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_proj_dealloc_ref(proj, error)
TYPE(pao_bas_projection_type), INTENT(inout) :: proj
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
integer :: handle, stat
character(len=*), parameter :: routineN='cp_proj_dealloc_ref',&
LOGICAL :: failure
INTEGER :: handle, stat
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_dealloc_ref',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
!call timeset(routineN//','//moduleN,'I',"",handle)
CPPrecondition(proj%initialized,cp_failure_level,routineP,error,failure)
if (.not. failure) then
deallocate(proj%proj_indexes, proj%non_proj_indexes, stat=stat)
IF (.NOT. failure) THEN
DEALLOCATE(proj%proj_indexes, proj%non_proj_indexes, stat=stat)
CPPostcondition(stat==0,cp_warning_level,routineP,error,failure)
proj%initialized=.false.
end if
call timestop(0.0_wp,handle)
end subroutine cp_proj_dealloc_ref
proj%initialized=.FALSE.
END IF
CALL timestop(0.0_wp,handle)
END SUBROUTINE cp_proj_dealloc_ref
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_valid [1.0] *
@ -516,21 +524,21 @@ end subroutine cp_proj_dealloc
!! none
!!
!!*** **********************************************************************
function cp_proj_valid(proj,error) result(res)
type(pao_bas_projection_type), intent(in) :: proj
logical ::res
type(cp_error_type), optional, intent(inout) :: error
FUNCTION cp_proj_valid(proj,error) RESULT(res)
TYPE(pao_bas_projection_type), INTENT(in) :: proj
LOGICAL ::res
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_proj_valid',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_valid',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
CPPrecondition(proj%initialized,cp_failure_level,routineP,error,failure)
CPPrecondition(associated(proj%proj_indexes),cp_warning_level,routineP,error,failure)
CPPrecondition(associated(proj%non_proj_indexes),cp_warning_level,routineP,error,failure)
CPPrecondition(ASSOCIATED(proj%proj_indexes),cp_warning_level,routineP,error,failure)
CPPrecondition(ASSOCIATED(proj%non_proj_indexes),cp_warning_level,routineP,error,failure)
res=.not.failure
end function cp_proj_valid
END FUNCTION cp_proj_valid
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_get [1.0] *
@ -575,30 +583,30 @@ end subroutine cp_proj_dealloc
!! none
!!
!!*** **********************************************************************
subroutine cp_proj_get(proj, size_min_bas, size_full_bas, &
SUBROUTINE cp_proj_get(proj, size_min_bas, size_full_bas, &
size_excl_bas, proj_indexes, non_proj_indexes, error)
type(pao_bas_projection_type), intent(in) :: proj
integer, optional, intent(out) :: size_excl_bas,size_full_bas,&
TYPE(pao_bas_projection_type), INTENT(in) :: proj
INTEGER, OPTIONAL, INTENT(out) :: size_excl_bas,size_full_bas,&
size_min_bas
integer, optional, dimension(:), pointer :: proj_indexes,&
INTEGER, OPTIONAL, DIMENSION(:), POINTER :: proj_indexes,&
non_proj_indexes
type(cp_error_type), optional, intent(inout) :: error
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
CPPrecondition(proj%initialized,cp_failure_level,routineP,error,failure)
if (.not. failure) then
if (present(size_min_bas)) size_min_bas=size(proj%proj_indexes)
if (present(size_full_bas)) &
size_full_bas=size(proj%proj_indexes)+size(proj%non_proj_indexes)
if (present(size_excl_bas)) size_excl_bas=size(proj%non_proj_indexes)
if (present(proj_indexes)) proj_indexes => proj%proj_indexes
if (present(non_proj_indexes)) non_proj_indexes => proj%non_proj_indexes
end if
end subroutine cp_proj_get
IF (.NOT. failure) THEN
IF (PRESENT(size_min_bas)) size_min_bas=SIZE(proj%proj_indexes)
IF (PRESENT(size_full_bas)) &
size_full_bas=SIZE(proj%proj_indexes)+SIZE(proj%non_proj_indexes)
IF (PRESENT(size_excl_bas)) size_excl_bas=SIZE(proj%non_proj_indexes)
IF (PRESENT(proj_indexes)) proj_indexes => proj%proj_indexes
IF (PRESENT(non_proj_indexes)) non_proj_indexes => proj%non_proj_indexes
END IF
END SUBROUTINE cp_proj_get
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_get_proj_indexes [1.0] *
@ -632,25 +640,25 @@ end subroutine cp_proj_dealloc
!! none
!!
!!*** **********************************************************************
function cp_proj_get_proj_indexes(proj, error) result(res)
type(pao_bas_projection_type), intent(in) :: proj
integer, dimension(:), pointer :: res
type(cp_error_type), optional, intent(inout) :: error
FUNCTION cp_proj_get_proj_indexes(proj, error) RESULT(res)
TYPE(pao_bas_projection_type), INTENT(in) :: proj
INTEGER, DIMENSION(:), POINTER :: res
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_proj_get_proj_indexes',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_get_proj_indexes',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
if (cp_debug.and.debug_this_module) then
IF (cp_debug.and.debug_this_module) THEN
CPPrecondition(cp_proj_valid(proj,error=error),cp_failure_level,routineP,error,failure)
end if
if (.not. failure) then
END IF
IF (.NOT. failure) THEN
res => proj%proj_indexes
else
nullify(res)
end if
end function cp_proj_get_proj_indexes
ELSE
NULLIFY(res)
END IF
END FUNCTION cp_proj_get_proj_indexes
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_get_non_proj_indexes [1.0] *
@ -684,25 +692,25 @@ end subroutine cp_proj_dealloc
!! none
!!
!!*** **********************************************************************
function cp_proj_get_non_proj_indexes(proj, error) result(res)
type(pao_bas_projection_type), intent(in) :: proj
integer, dimension(:), pointer :: res
type(cp_error_type), optional, intent(inout) :: error
FUNCTION cp_proj_get_non_proj_indexes(proj, error) RESULT(res)
TYPE(pao_bas_projection_type), INTENT(in) :: proj
INTEGER, DIMENSION(:), POINTER :: res
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_proj_get_non_proj_indexes',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_get_non_proj_indexes',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
if (cp_debug.and.debug_this_module) then
IF (cp_debug.and.debug_this_module) THEN
CPPrecondition(cp_proj_valid(proj,error=error),cp_failure_level,routineP,error,failure)
end if
if (.not. failure) then
END IF
IF (.NOT. failure) THEN
res => proj%non_proj_indexes
else
nullify(res)
end if
end function cp_proj_get_non_proj_indexes
ELSE
NULLIFY(res)
END IF
END FUNCTION cp_proj_get_non_proj_indexes
!***************************************************************************
!!****f* pao_bas_projection/cp_proj_write [1.0] *
@ -736,24 +744,24 @@ end subroutine cp_proj_dealloc
!! 4.2002 created [fawzi]
!!
!!*** **********************************************************************
subroutine cp_proj_write(proj,unit_nr,error)
type(pao_bas_projection_type), intent(in), target :: proj
integer, intent(in) :: unit_nr
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE cp_proj_write(proj,unit_nr,error)
TYPE(pao_bas_projection_type), INTENT(in), TARGET :: proj
INTEGER, INTENT(in) :: unit_nr
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='cp_proj_write',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='cp_proj_write',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
CPPrecondition(proj%initialized,cp_failure_level,routineP,error,failure)
if (.not. failure) then
write(unit=unit_nr,fmt="(t2,a)")'# projection indexes'
call cp_write(proj%proj_indexes,unit_nr=unit_nr,error=error)
write(unit=unit_nr,fmt="(t2,a)")'# non projection indexes'
call cp_write(proj%non_proj_indexes,unit_nr=unit_nr,error=error)
end if
end subroutine cp_proj_write
IF (.NOT. failure) THEN
WRITE(unit=unit_nr,fmt="(t2,a)")'# projection indexes'
CALL cp_write(proj%proj_indexes,unit_nr=unit_nr,error=error)
WRITE(unit=unit_nr,fmt="(t2,a)")'# non projection indexes'
CALL cp_write(proj%non_proj_indexes,unit_nr=unit_nr,error=error)
END IF
END SUBROUTINE cp_proj_write
!***************************************************************************
end module pao_bas_projection_types
END MODULE pao_bas_projection_types

476
src/pao_env_methods.F
View file

@ -25,44 +25,70 @@
!!
!! SOURCE
!*****************************************************************************
module pao_env_methods
use cp_log_handling, only: cp_to_string, cp_failure_level, cp_warning_level,&
cp_note_level, cp_logger_type
use cp_error_handling, only: cp_debug, cp_error_type, cp_assert, &
cp_error_message, cp_assertion_failed, cp_error_init,&
cp_error_get_print_level, cp_error_get_stop_level, cp_error_get_level,&
cp_error_dealloc_ref, cp_error_get_logger, cp_internal_error
use kinds, only: wp=>dp
use global_types, only: global_environment_type
use timings, only: timeset, timestop
use pao_types, only: pao_glob_angles_type, pao_env_type, cp_get, pao_env_valid
use qs_environment_types, only: qs_environment_type, get_qs_env
use cp_block_matrix, only: cp_block_matrix_type, cp_block_matrix_p_type,&
cp_sp_create, cp_get_matrix, cp_retain, cp_release
use pao_glob_angles_methods, only: pao_g_ang_init, cp_dealloc, cp_set
use sparse_matrix_types, only: real_matrix_p_type, real_matrix_type
use pao_bas_projection_types, only: pao_bas_projection_type,cp_proj_get
use pao_qs_env_methods, only: cp_get_b_projection
use atomic_kind_types, only: atomic_kind_type, get_atomic_kind, &
get_atomic_kind_set
use cp_b_matrix_structure, only: cp_b_matrix_struct_type, &
cp_bmstruct_create, cp_bmstruct_release
use cp_para_types, only: cp_para_env_type
implicit none
private
MODULE pao_env_methods
USE atomic_kind_types, ONLY: atomic_kind_type,&
get_atomic_kind,&
get_atomic_kind_set
USE cp_b_matrix_structure, ONLY: cp_b_matrix_struct_type,&
cp_bmstruct_create,&
cp_bmstruct_release
USE cp_block_matrix, ONLY: cp_block_matrix_p_type,&
cp_block_matrix_type,&
cp_get_matrix,&
cp_release,&
cp_retain,&
cp_sp_create
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_level,&
cp_error_get_logger,&
cp_error_get_print_level,&
cp_error_get_stop_level,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_para_types, ONLY: cp_para_env_type
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE pao_bas_projection_types, ONLY: cp_proj_get,&
pao_bas_projection_type
USE pao_glob_angles_methods, ONLY: cp_dealloc,&
cp_set,&
pao_g_ang_init
USE pao_qs_env_methods, ONLY: cp_get_b_projection
USE pao_types, ONLY: cp_get,&
pao_env_type,&
pao_env_valid,&
pao_glob_angles_type
USE qs_environment_types, ONLY: get_qs_env,&
qs_environment_type
USE sparse_matrix_types, ONLY: real_matrix_p_type,&
real_matrix_type
USE timings, ONLY: timeset,&
timestop
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
logical, private, parameter :: standalone=.true.
character(len=*), private, parameter :: moduleN='pao_env_methods'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
LOGICAL, PRIVATE, PARAMETER :: standalone=.TRUE.
CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='pao_env_methods'
! core procedures
public :: cp_init, cp_dealloc_ref, cp_set
PUBLIC :: cp_init, cp_dealloc_ref, cp_set
! core functions
public :: cp_validate
PUBLIC :: cp_validate
! underlying routines
public :: pao_env_init, pao_env_dealloc_ref, pao_env_validate,&
PUBLIC :: pao_env_init, pao_env_dealloc_ref, pao_env_validate,&
pao_env_set
! ============== interfaces ===========
@ -72,34 +98,34 @@ module pao_env_methods
!! initializes the first, argument.
!! Support optional initial values that depend on the
!! first argument
interface cp_init
module procedure pao_env_init
end interface
INTERFACE cp_init
MODULE PROCEDURE pao_env_init
END INTERFACE
!! Deallocates the memory allocated by the first argument.
!! Supports error=error
interface cp_dealloc_ref
module procedure pao_env_dealloc_ref
end interface
INTERFACE cp_dealloc_ref
MODULE PROCEDURE pao_env_dealloc_ref
END INTERFACE
!! returns true if the content of the first argumenst is valid.
!! writes the errors ar warnings, full validation (long)
interface cp_validate
module procedure pao_env_validate
end interface
INTERFACE cp_validate
MODULE PROCEDURE pao_env_validate
END INTERFACE
!! sets the value of various optonal attributes of the firs argument.
!! the optional attributes depend on the type of the first
interface cp_set
module procedure pao_env_set
end interface
INTERFACE cp_set
MODULE PROCEDURE pao_env_set
END INTERFACE
! +++ end of the core methods +++
!!***
!****************************************************************************
contains
CONTAINS
! ====== core methods =====
@ -146,122 +172,122 @@ contains
!! 05.2002 updated doc [fawzi]
!!
!!*** **********************************************************************
subroutine pao_env_init(pao_env, qs_env, global_env,&
SUBROUTINE pao_env_init(pao_env, qs_env, global_env,&
wanted_subspace_pos_precision,&
wanted_in_subspace_precision,&
error)
type(pao_env_type), intent(out) :: pao_env
type(global_environment_type), intent(in), target :: global_env
type(qs_environment_type), intent(inout), target :: qs_env
real(kind=wp), optional, intent(in) :: wanted_in_subspace_precision, &
TYPE(pao_env_type), INTENT(out) :: pao_env
TYPE(global_environment_type), INTENT(in), TARGET :: global_env
TYPE(qs_environment_type), INTENT(inout), TARGET :: qs_env
REAL(kind=wp), OPTIONAL, INTENT(in) :: wanted_in_subspace_precision, &
wanted_subspace_pos_precision
type(cp_error_type), optional, intent(inout) :: error
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineP='pao_env_methods:pao_env_init'
type(cp_error_type) :: iError
integer :: stat, i, n_atoms, size_excl_bas, size_min_bas, size_full_bas,j
type(pao_bas_projection_type), pointer :: bproj
integer, dimension(:), allocatable :: min_bas_sizes, full_bas_sizes
type(atomic_kind_type), dimension(:), pointer :: atomic_kind_set
integer, dimension(:), pointer :: atom_list
character(len=60) :: name
failure=.false.
call cp_error_init(iError, template_error=error)
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineP='pao_env_methods:pao_env_init'
TYPE(cp_error_type) :: iError
INTEGER :: stat, i, n_atoms, size_excl_bas, size_min_bas, size_full_bas,j
TYPE(pao_bas_projection_type), POINTER :: bproj
INTEGER, DIMENSION(:), ALLOCATABLE :: min_bas_sizes, full_bas_sizes
TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
INTEGER, DIMENSION(:), POINTER :: atom_list
CHARACTER(len=60) :: name
failure=.FALSE.
CALL cp_error_init(iError, template_error=error)
nullify(pao_env%angles_begin_at, pao_env%atomic_ortho_valid,&
NULLIFY(pao_env%angles_begin_at, pao_env%atomic_ortho_valid,&
pao_env%atomic_ortho, pao_env%min_density_m,&
pao_env%min_bas_m_struct, pao_env%full_bas_m_struct,&
pao_env%full_min_bas_m_struct, pao_env%min_full_bas_m_struct,&
pao_env%full_bas_diag_m_struct)
pao_env%min_d_m_valid=.false.
pao_env%min_d_m_valid=.FALSE.
! check projection
call get_qs_env(qs_env, atomic_kind_set= atomic_kind_set)
n_atoms=size(qs_env%particle_set)
CPPrecondition(associated(atomic_kind_set),cp_failure_level,routineP,error,failure)
if (.not.failure) then
allocate(min_bas_sizes(n_atoms), full_bas_sizes(n_atoms),stat=stat)
CALL get_qs_env(qs_env, atomic_kind_set= atomic_kind_set)
n_atoms=SIZE(qs_env%particle_set)
CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure)
IF (.not.failure) THEN
ALLOCATE(min_bas_sizes(n_atoms), full_bas_sizes(n_atoms),stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
end if
if (.not.failure) then
do i=1,size(atomic_kind_set)
call get_atomic_kind(atomic_kind_set(i),pao_bas_proj=bproj,&
END IF
IF (.not.failure) THEN
DO i=1,SIZE(atomic_kind_set)
CALL get_atomic_kind(atomic_kind_set(i),pao_bas_proj=bproj,&
atom_list=atom_list)
if (.not.associated(bproj)) then
call get_atomic_kind(atomic_kind_set(i),name=name)
call cp_assert(.false.,cp_failure_level, cp_internal_error,&
IF (.not.ASSOCIATED(bproj)) THEN
CALL get_atomic_kind(atomic_kind_set(i),name=name)
CALL cp_assert(.FALSE.,cp_failure_level, cp_internal_error,&
routineP,&
"projection (PAO_MIN_BAS) not defined in kind "//name &
//", "//&
CPSourceFileRef,&
error=error,failure=failure)
else
call cp_proj_get(bproj,size_min_bas=size_min_bas,&
ELSE
CALL cp_proj_get(bproj,size_min_bas=size_min_bas,&
size_full_bas=size_full_bas,error=error)
do j=1,size(atom_list)
DO j=1,SIZE(atom_list)
min_bas_sizes(atom_list(j))=size_min_bas
full_bas_sizes(atom_list(j))=size_full_bas
end do
end if
end do
END DO
END IF
END DO
! min_bas_m_struct / full_bas_m_struct
if (.not.failure) then
call cp_bmstruct_create(pao_env%min_bas_m_struct,&
symmetric=.true.,&
IF (.not.failure) THEN
CALL cp_bmstruct_create(pao_env%min_bas_m_struct,&
symmetric=.TRUE.,&
para_env=global_env%para_env,&
b_row_sizes=min_bas_sizes,&
b_col_sizes=min_bas_sizes,&
error=error)
call cp_bmstruct_create(pao_env%full_bas_m_struct,&
symmetric=.false.,&
CALL cp_bmstruct_create(pao_env%full_bas_m_struct,&
symmetric=.FALSE.,&
para_env=global_env%para_env,&
b_row_sizes=full_bas_sizes,&
b_col_sizes=full_bas_sizes,&
error=error)
call cp_bmstruct_create(pao_env%full_min_bas_m_struct,&
symmetric=.false.,&
CALL cp_bmstruct_create(pao_env%full_min_bas_m_struct,&
symmetric=.FALSE.,&
para_env=global_env%para_env,&
b_row_sizes=full_bas_sizes,&
b_col_sizes=min_bas_sizes,&
error=error)
call cp_bmstruct_create(pao_env%min_full_bas_m_struct,&
symmetric=.false.,&
CALL cp_bmstruct_create(pao_env%min_full_bas_m_struct,&
symmetric=.FALSE.,&
para_env=global_env%para_env,&
b_row_sizes=min_bas_sizes,&
b_col_sizes=full_bas_sizes,&
error=error)
call cp_bmstruct_create(pao_env%full_bas_diag_m_struct,&
symmetric=.false.,&
CALL cp_bmstruct_create(pao_env%full_bas_diag_m_struct,&
symmetric=.FALSE.,&
para_env=global_env%para_env,&
b_row_sizes=full_bas_sizes,&
b_col_sizes=full_bas_sizes,&
error=error)
pao_env%full_bas_diag_m_struct%sparsity=.false.
do i=1,size(pao_env%full_bas_diag_m_struct%sparsity,1)
pao_env%full_bas_diag_m_struct%sparsity(i,i)=.true.
end do
end if
pao_env%full_bas_diag_m_struct%sparsity=.FALSE.
DO i=1,SIZE(pao_env%full_bas_diag_m_struct%sparsity,1)
pao_env%full_bas_diag_m_struct%sparsity(i,i)=.TRUE.
END DO
END IF
! angles_begin_at
if (.not.failure) then
allocate(pao_env%angles_begin_at(n_atoms+1),stat=stat)
IF (.not.failure) THEN
ALLOCATE(pao_env%angles_begin_at(n_atoms+1),stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
end if
if (.not.failure) then
if (n_atoms>0) pao_env%angles_begin_at(1)=0
do i=1,n_atoms
END IF
IF (.not.failure) THEN
IF (n_atoms>0) pao_env%angles_begin_at(1)=0
DO i=1,n_atoms
pao_env%angles_begin_at(i+1)=pao_env%angles_begin_at(i)+&
min_bas_sizes(i)*(full_bas_sizes(i)-min_bas_sizes(i))
end do
end if
END DO
END IF
deallocate(min_bas_sizes, full_bas_sizes, stat=stat)
DEALLOCATE(min_bas_sizes, full_bas_sizes, stat=stat)
CPPostcondition(stat==0,cp_warning_level,routineP,error,failure)
end if
END IF
! cache_max vals
call get_atomic_kind_set(atomic_kind_set,&
CALL get_atomic_kind_set(atomic_kind_set,&
pao_max_min_bas=pao_env%max_min_bas,&
pao_max_full_bas=pao_env%max_full_bas,&
pao_max_excl_bas=pao_env%max_excl_bas,&
@ -271,48 +297,48 @@ contains
pao_max_l_angles=pao_env%max_l_angles)
! others
n_atoms=size(qs_env%particle_set)
allocate(pao_env%min_density_m(1),stat=stat)
n_atoms=SIZE(qs_env%particle_set)
ALLOCATE(pao_env%min_density_m(1),stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
if (.not.failure) then
do i=1,size(pao_env%min_density_m)
nullify(pao_env%min_density_m(i)%matrix)
end do
end if
allocate(pao_env%angles_att,stat=stat)
IF (.not.failure) THEN
DO i=1,SIZE(pao_env%min_density_m)
NULLIFY(pao_env%min_density_m(i)%matrix)
END DO
END IF
ALLOCATE(pao_env%angles_att,stat=stat)
CPPostcondition(stat==0,cp_failure_level,routineP,error,failure)
pao_env%wanted_subspace_pos_precision=1.0e-4_wp
pao_env%wanted_in_subspace_precision=1.0e-4_wp
pao_env%initialized=.true.
pao_env%initialized=.TRUE.
! min_d
if (.not.failure) then
do i=1,size(pao_env%min_density_m)
call cp_sp_create(pao_env%min_density_m(i)%matrix,&
IF (.not.failure) THEN
DO i=1,SIZE(pao_env%min_density_m)
CALL cp_sp_create(pao_env%min_density_m(i)%matrix,&
matrix_struct=pao_env%min_bas_m_struct,&
error=error)
end do
end if
END DO
END IF
! angles_att
if (.not.failure) then
call pao_g_ang_init(pao_env%angles_att, global_env=global_env,&
IF (.not.failure) THEN
CALL pao_g_ang_init(pao_env%angles_att, global_env=global_env,&
qs_env=qs_env, error=error)
end if
END IF
call pao_env_set(pao_env,qs_env=qs_env, global_env=global_env,&
CALL pao_env_set(pao_env,qs_env=qs_env, global_env=global_env,&
wanted_subspace_pos_precision=wanted_subspace_pos_precision,&
wanted_in_subspace_precision=wanted_in_subspace_precision,&
error=error)
if (cp_debug.and.debug_this_module) then
call cp_assert(cp_validate(pao_env,qs_env=qs_env,&
IF (cp_debug.and.debug_this_module) THEN
CALL cp_assert(cp_validate(pao_env,qs_env=qs_env,&
global_env=global_env,&
test_pos_att=.false.,error=error),&
test_pos_att=.FALSE.,error=error),&
cp_failure_level,cp_assertion_failed,routineP,&
"pao_env is not valid after init in "//&
CPSourceFileRef,&
error,failure)
end if
call cp_error_dealloc_ref(iError,error)
end subroutine pao_env_init
END IF
CALL cp_error_dealloc_ref(iError,error)
END SUBROUTINE pao_env_init
!***************************************************************************
!!****f* pao_env_methods/pao_env_dealloc_ref [1.0] *
@ -350,57 +376,57 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine pao_env_dealloc_ref(pao_env,qs_env,global_env, error)
type(pao_env_type), intent(inout) :: pao_env
type(global_environment_type), intent(in), target :: global_env
type(qs_environment_type), intent(inout), target :: qs_env
type(cp_error_type), optional, intent(inout) :: error
SUBROUTINE pao_env_dealloc_ref(pao_env,qs_env,global_env, error)
TYPE(pao_env_type), INTENT(inout) :: pao_env
TYPE(global_environment_type), INTENT(in), TARGET :: global_env
TYPE(qs_environment_type), INTENT(inout), TARGET :: qs_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineP='pao_env_methods:pao_env_dealloc_ref'
integer :: stat,i
failure=.false.
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineP='pao_env_methods:pao_env_dealloc_ref'
INTEGER :: stat,i
failure=.FALSE.
CPPrecondition(pao_env%initialized,cp_failure_level,routineP,error,failure)
failureIf: if (.not. failure) then
if (associated(pao_env%angles_att)) then
call cp_dealloc(pao_env%angles_att,global_env=global_env,&
failureIf: IF (.NOT. failure) THEN
IF (ASSOCIATED(pao_env%angles_att)) THEN
CALL cp_dealloc(pao_env%angles_att,global_env=global_env,&
error=error)
end if
if (associated(pao_env%angles_begin_at)) then
deallocate(pao_env%angles_begin_at,stat=stat)
END IF
IF (ASSOCIATED(pao_env%angles_begin_at)) THEN
DEALLOCATE(pao_env%angles_begin_at,stat=stat)
CPPostcondition(stat==0,cp_warning_level,routineP,error,failure)
end if
if (associated(pao_env%min_bas_m_struct)) then
call cp_bmstruct_release(pao_env%min_bas_m_struct,error=error)
nullify(pao_env%min_bas_m_struct)
end if
if (associated(pao_env%full_bas_m_struct)) then
call cp_bmstruct_release(pao_env%full_bas_m_struct, error=error)
nullify(pao_env%full_bas_m_struct)
end if
if (associated(pao_env%full_min_bas_m_struct)) then
call cp_bmstruct_release(pao_env%full_min_bas_m_struct, error=error)
nullify(pao_env%full_min_bas_m_struct)
end if
if (associated(pao_env%min_full_bas_m_struct)) then
call cp_bmstruct_release(pao_env%min_full_bas_m_struct, error=error)
nullify(pao_env%min_full_bas_m_struct)
end if
if (associated(pao_env%full_bas_diag_m_struct)) then
call cp_bmstruct_release(pao_env%full_bas_diag_m_struct, error=error)
nullify(pao_env%full_bas_diag_m_struct)
end if
if (associated(pao_env%atomic_ortho)) then
call cp_release(pao_env%atomic_ortho,error=error)
end if
if (associated(pao_env%atomic_ortho_valid)) then
deallocate(pao_env%atomic_ortho_valid, stat=stat)
END IF
IF (ASSOCIATED(pao_env%min_bas_m_struct)) THEN
CALL cp_bmstruct_release(pao_env%min_bas_m_struct,error=error)
NULLIFY(pao_env%min_bas_m_struct)
END IF
IF (ASSOCIATED(pao_env%full_bas_m_struct)) THEN
CALL cp_bmstruct_release(pao_env%full_bas_m_struct, error=error)
NULLIFY(pao_env%full_bas_m_struct)
END IF
IF (ASSOCIATED(pao_env%full_min_bas_m_struct)) THEN
CALL cp_bmstruct_release(pao_env%full_min_bas_m_struct, error=error)
NULLIFY(pao_env%full_min_bas_m_struct)
END IF
IF (ASSOCIATED(pao_env%min_full_bas_m_struct)) THEN
CALL cp_bmstruct_release(pao_env%min_full_bas_m_struct, error=error)
NULLIFY(pao_env%min_full_bas_m_struct)
END IF
IF (ASSOCIATED(pao_env%full_bas_diag_m_struct)) THEN
CALL cp_bmstruct_release(pao_env%full_bas_diag_m_struct, error=error)
NULLIFY(pao_env%full_bas_diag_m_struct)
END IF
IF (ASSOCIATED(pao_env%atomic_ortho)) THEN
CALL cp_release(pao_env%atomic_ortho,error=error)
END IF
IF (ASSOCIATED(pao_env%atomic_ortho_valid)) THEN
DEALLOCATE(pao_env%atomic_ortho_valid, stat=stat)
CPPostcondition(stat==0,cp_warning_level,routineP,error,failure)
end if
pao_env%initialized=.false.
end if failureIf
end subroutine pao_env_dealloc_ref
END IF
pao_env%initialized=.FALSE.
END IF failureIf
END SUBROUTINE pao_env_dealloc_ref
!***************************************************************************
@ -444,31 +470,31 @@ contains
!! none
!!
!!*** **********************************************************************
function pao_env_validate(pao_env,qs_env,global_env, test_pos_att, error)&
result(res)
logical ::res
type(pao_env_type), intent(in), target :: pao_env
type(qs_environment_type), intent(in),target :: qs_env
type(global_environment_type), intent(in), target :: global_env
logical ,optional ::test_pos_att
type(cp_error_type), optional, intent(inout) :: error
FUNCTION pao_env_validate(pao_env,qs_env,global_env, test_pos_att, error)&
RESULT(res)
LOGICAL ::res
TYPE(pao_env_type), INTENT(in), TARGET :: pao_env
TYPE(qs_environment_type), INTENT(in),TARGET :: qs_env
TYPE(global_environment_type), INTENT(in), TARGET :: global_env
LOGICAL ,OPTIONAL ::test_pos_att
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure, test_pos
character(len=*), parameter :: routineP='pao_env_methods:pao_env_validate'
type(cp_logger_type), pointer :: logger
integer :: i,m_bas_att,f_bas_att,j
failure=.false.
LOGICAL :: failure, test_pos
CHARACTER(len=*), PARAMETER :: routineP='pao_env_methods:pao_env_validate'
TYPE(cp_logger_type), POINTER :: logger
INTEGER :: i,m_bas_att,f_bas_att,j
failure=.FALSE.
logger => cp_error_get_logger(error)
if (present(test_pos_att)) then
IF (PRESENT(test_pos_att)) THEN
test_pos=test_pos_att
else
test_pos=.true.
end if
ELSE
test_pos=.TRUE.
END IF
CPPrecondition(pao_env%initialized,cp_failure_level,routineP,error,failure)
failure=failure.and..not.pao_env_valid(pao_env,error=error)
! to do: more tests using qs_env
res=.not.failure
end function pao_env_validate
END FUNCTION pao_env_validate
!***************************************************************************
!!****f* pao_env_methods/pao_env_set [1.0] *
@ -517,48 +543,48 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine pao_env_set(pao_env, qs_env, global_env, &
SUBROUTINE pao_env_set(pao_env, qs_env, global_env, &
wanted_subspace_pos_precision,&
wanted_in_subspace_precision, angles_att, &
min_density_m, min_d_valid,error)
type(pao_env_type), target, intent(inout) :: pao_env
type(global_environment_type), intent(in), target :: global_env
type(qs_environment_type), intent(in), target :: qs_env
real(kind=wp), optional, intent(in) :: wanted_in_subspace_precision, &
TYPE(pao_env_type), TARGET, INTENT(inout) :: pao_env
TYPE(global_environment_type), INTENT(in), TARGET :: global_env
TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env
REAL(kind=wp), OPTIONAL, INTENT(in) :: wanted_in_subspace_precision, &
wanted_subspace_pos_precision
type(pao_glob_angles_type),optional, intent(in) :: angles_att
type(cp_block_matrix_p_type),optional, intent(in), dimension(:),&
target :: min_density_m
logical, optional :: min_d_valid
type(cp_error_type), optional, intent(inout) :: error
TYPE(pao_glob_angles_type),OPTIONAL, INTENT(in) :: angles_att
TYPE(cp_block_matrix_p_type),OPTIONAL, INTENT(in), DIMENSION(:),&
TARGET :: min_density_m
LOGICAL, OPTIONAL :: min_d_valid
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineP='pao_env_methods:pao_env_set'
integer :: stat
type(cp_error_type) :: iError
failure=.false.
call cp_error_init(iError,template_error=error)
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineP='pao_env_methods:pao_env_set'
INTEGER :: stat
TYPE(cp_error_type) :: iError
failure=.FALSE.
CALL cp_error_init(iError,template_error=error)
CPPrecondition(pao_env%initialized,cp_failure_level,routineP,error,failure)
if (present(wanted_subspace_pos_precision)) &
IF (PRESENT(wanted_subspace_pos_precision)) &
pao_env%wanted_subspace_pos_precision=wanted_subspace_pos_precision
if (present(wanted_in_subspace_precision)) &
IF (PRESENT(wanted_in_subspace_precision)) &
pao_env%wanted_in_subspace_precision=wanted_in_subspace_precision
if (present(angles_att)) then
call cp_set(pao_env%angles_att, qs_env=qs_env, global_env=global_env,&
IF (PRESENT(angles_att)) THEN
CALL cp_set(pao_env%angles_att, qs_env=qs_env, global_env=global_env,&
source=angles_att, error=error)
end if
if (present(min_density_m)) then
pao_env%min_d_m_valid=.true.
END IF
IF (PRESENT(min_density_m)) THEN
pao_env%min_d_m_valid=.TRUE.
! to do
CPAssert(.false.,cp_warning_level,routineP,error,failure)
CPAssert(.FALSE.,cp_warning_level,routineP,error,failure)
pao_env%min_density_m => min_density_m
end if
if (present(min_d_valid)) then
END IF
IF (PRESENT(min_d_valid)) THEN
pao_env%min_d_m_valid=min_d_valid
end if
call cp_error_dealloc_ref(iError,error=error)
end subroutine pao_env_set
END IF
CALL cp_error_dealloc_ref(iError,error=error)
END SUBROUTINE pao_env_set
!***************************************************************************
end module pao_env_methods
END MODULE pao_env_methods

900
src/pao_glob_angles_methods.F
View file

File diff suppressed because it is too large Load diff

181
src/pao_plain_rot.F
View file

@ -26,29 +26,40 @@
!! SOURCE
!******************************************************************************
module pao_plain_rot
use cp_log_handling, only: cp_fatal_level, cp_failure_level,&
cp_warning_level, cp_note_level, cp_to_string, cp_log,&
cp_logger_get_default_unit_nr, cp_logger_type
use cp_error_handling, only: cp_debug, cp_error_type, cp_error_init,&
cp_error_dealloc_ref, cp_error_message, cp_assert,&
cp_assertion_failed, cp_internal_error, cp_unimplemented_error,&
cp_error_get_logger
use kinds, only: wp=>dp
use cp_matrix_utils, only: cp_sup_norm_matrix
implicit none
private
MODULE pao_plain_rot
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_internal_error,&
cp_unimplemented_error
USE cp_log_handling, ONLY: cp_failure_level,&
cp_fatal_level,&
cp_log,&
cp_logger_get_default_unit_nr,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_matrix_utils, ONLY: cp_sup_norm_matrix
USE kinds, ONLY: wp=>dp
IMPLICIT NONE
PRIVATE
logical, parameter, private :: debug_this_module=.true.
character(len=*), parameter, private :: moduleN='pao_plain_rot'
LOGICAL, PARAMETER, PRIVATE :: debug_this_module=.TRUE.
CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN='pao_plain_rot'
public :: cp_left_compose_p_rot, cp_right_compose_p_rot,&
PUBLIC :: cp_left_compose_p_rot, cp_right_compose_p_rot,&
cp_right_compose_p_rot_deriv, cp_left_compose_p_rot_deriv
!!***
!****************************************************************************
contains
CONTAINS
!!****f* pao_plain_rot/cp_right_compose_p_rot [1.0] *
@ -97,30 +108,30 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_right_compose_p_rot(matrix,angle,i,j,error)
real(kind=wp), dimension(:,:), intent(inout) :: matrix
real(kind=wp), intent(in) :: angle
integer, intent(in) :: i,j
type(cp_error_type), intent(inout), optional :: error
SUBROUTINE cp_right_compose_p_rot(matrix,angle,i,j,error)
REAL(kind=wp), DIMENSION(:,:), INTENT(inout) :: matrix
REAL(kind=wp), INTENT(in) :: angle
INTEGER, INTENT(in) :: i,j
TYPE(cp_error_type), INTENT(inout), OPTIONAL :: error
logical :: failure
real(kind=wp) :: rcos,rsin
real(kind=wp), dimension(size(matrix,1)) :: tmpV1, tmpV2
character(len=*), parameter :: routineN='cp_right_compose_p_rot',&
LOGICAL :: failure
REAL(kind=wp) :: rcos,rsin
REAL(kind=wp), DIMENSION(SIZE(matrix,1)) :: tmpV1, tmpV2
CHARACTER(len=*), PARAMETER :: routineN='cp_right_compose_p_rot',&
routineP=moduleN//':'//routineN
failure=.false.
if (cp_debug .and. debug_this_module) then ! this function must be fast
failure=.FALSE.
IF (cp_debug .AND. debug_this_module) THEN ! this function must be fast
CPPrecondition(i /= j,cp_failure_level,routineP,error,failure)
end if
if (.not. failure) then
rcos=cos(angle)
rsin=sin(angle)
END IF
IF (.NOT. failure) THEN
rcos=COS(angle)
rsin=SIN(angle)
tmpV1 = rcos*matrix(:,i)+rsin*matrix(:,j)
tmpV2 = -rsin*matrix(:,i)+rcos*matrix(:,j)
matrix(:,i)=tmpV1
matrix(:,j)=tmpV2
end if
end subroutine cp_right_compose_p_rot
END IF
END SUBROUTINE cp_right_compose_p_rot
!***************************************************************************
@ -171,30 +182,30 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_left_compose_p_rot(matrix,angle,i,j, error)
real(kind=wp), dimension(:,:), intent(inout) :: matrix
real(kind=wp), intent(in) :: angle
integer, intent(in) :: i,j
type(cp_error_type), intent(inout), optional :: error
SUBROUTINE cp_left_compose_p_rot(matrix,angle,i,j, error)
REAL(kind=wp), DIMENSION(:,:), INTENT(inout) :: matrix
REAL(kind=wp), INTENT(in) :: angle
INTEGER, INTENT(in) :: i,j
TYPE(cp_error_type), INTENT(inout), OPTIONAL :: error
logical :: failure
real(kind=wp) :: rcos,rsin
real(kind=wp), dimension(size(matrix,2)) :: tmpV1,tmpV2
character(len=*), parameter :: routineN='cp_left_compose_p_rot',&
LOGICAL :: failure
REAL(kind=wp) :: rcos,rsin
REAL(kind=wp), DIMENSION(SIZE(matrix,2)) :: tmpV1,tmpV2
CHARACTER(len=*), PARAMETER :: routineN='cp_left_compose_p_rot',&
routineP=moduleN//':'//routineN
failure=.false.
if (debug_this_module) then ! this function must be fast
failure=.FALSE.
IF (debug_this_module) THEN ! this function must be fast
CPPrecondition(i /= j,cp_failure_level,routineP,error,failure)
end if
if (.not. failure) then
rcos=cos(angle)
rsin=sin(angle)
END IF
IF (.NOT. failure) THEN
rcos=COS(angle)
rsin=SIN(angle)
tmpV1 = rcos*matrix(i,:)-rsin*matrix(j,:)
tmpV2 = rsin*matrix(i,:)+rcos*matrix(j,:)
matrix(i,:)=tmpV1
matrix(j,:)=tmpV2
end if
end subroutine cp_left_compose_p_rot
END IF
END SUBROUTINE cp_left_compose_p_rot
!***************************************************************************
!!****f* pao_plain_rot/cp_right_compose_p_rot_deriv [1.0] *
@ -233,31 +244,31 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_right_compose_p_rot_deriv(matrix,angle,i,j,error)
real(kind=wp), dimension(:,:), intent(inout) :: matrix
real(kind=wp), intent(in) :: angle
integer, intent(in) :: i,j
type(cp_error_type), intent(inout), optional :: error
SUBROUTINE cp_right_compose_p_rot_deriv(matrix,angle,i,j,error)
REAL(kind=wp), DIMENSION(:,:), INTENT(inout) :: matrix
REAL(kind=wp), INTENT(in) :: angle
INTEGER, INTENT(in) :: i,j
TYPE(cp_error_type), INTENT(inout), OPTIONAL :: error
logical :: failure
real(kind=wp) :: rcos,rsin
real(kind=wp), dimension(size(matrix,1)) :: tmpV1, tmpV2
character(len=*), parameter :: routineN='cp_right_compose_p_rot_deriv',&
LOGICAL :: failure
REAL(kind=wp) :: rcos,rsin
REAL(kind=wp), DIMENSION(SIZE(matrix,1)) :: tmpV1, tmpV2
CHARACTER(len=*), PARAMETER :: routineN='cp_right_compose_p_rot_deriv',&
routineP=moduleN//':'//routineN
failure=.false.
if (cp_debug .and. debug_this_module) then ! this function must be fast
failure=.FALSE.
IF (cp_debug .AND. debug_this_module) THEN ! this function must be fast
CPPrecondition(i /= j,cp_failure_level,routineP,error,failure)
end if
if (.not. failure) then
rcos=cos(angle)
rsin=sin(angle)
END IF
IF (.NOT. failure) THEN
rcos=COS(angle)
rsin=SIN(angle)
tmpV1 = -rsin*matrix(:,i)+rcos*matrix(:,j)
tmpV2 = -rcos*matrix(:,i)-rsin*matrix(:,j)
matrix=0.0_wp
matrix(:,i)=tmpV1
matrix(:,j)=tmpV2
end if
end subroutine cp_right_compose_p_rot_deriv
END IF
END SUBROUTINE cp_right_compose_p_rot_deriv
!***************************************************************************
!!****f* pao_plain_rot/cp_left_compose_p_rot_deriv [1.0] *
@ -296,34 +307,34 @@ contains
!! none
!!
!!*** **********************************************************************
subroutine cp_left_compose_p_rot_deriv(matrix,angle,i,j,error)
real(kind=wp), dimension(:,:), intent(inout) :: matrix
real(kind=wp), intent(in) :: angle
integer, intent(in) :: i,j
type(cp_error_type), intent(inout), optional :: error
SUBROUTINE cp_left_compose_p_rot_deriv(matrix,angle,i,j,error)
REAL(kind=wp), DIMENSION(:,:), INTENT(inout) :: matrix
REAL(kind=wp), INTENT(in) :: angle
INTEGER, INTENT(in) :: i,j
TYPE(cp_error_type), INTENT(inout), OPTIONAL :: error
logical :: failure
real(kind=wp) :: rcos,rsin
real(kind=wp), dimension(size(matrix,2)) :: tmpV1, tmpV2
character(len=*), parameter :: routineN='cp_left_compose_p_rot_deriv',&
LOGICAL :: failure
REAL(kind=wp) :: rcos,rsin
REAL(kind=wp), DIMENSION(SIZE(matrix,2)) :: tmpV1, tmpV2
CHARACTER(len=*), PARAMETER :: routineN='cp_left_compose_p_rot_deriv',&
routineP=moduleN//':'//routineN
failure=.false.
if (cp_debug .and. debug_this_module) then ! this function must be fast
failure=.FALSE.
IF (cp_debug .AND. debug_this_module) THEN ! this function must be fast
CPPrecondition(i /= j,cp_failure_level,routineP,error,failure)
end if
if (.not. failure) then
rcos=cos(angle)
rsin=sin(angle)
END IF
IF (.NOT. failure) THEN
rcos=COS(angle)
rsin=SIN(angle)
tmpV1 = -rsin*matrix(i,:)-rcos*matrix(j,:)
tmpV2 = rcos*matrix(i,:)-rsin*matrix(j,:)
matrix=0.0_wp
matrix(i,:)=tmpV1
matrix(j,:)=tmpV2
end if
end subroutine cp_left_compose_p_rot_deriv
END IF
END SUBROUTINE cp_left_compose_p_rot_deriv
!***************************************************************************
end module pao_plain_rot
END MODULE pao_plain_rot

340
src/pao_plain_rot_tests.F
View file

@ -25,34 +25,48 @@
!!
!! SOURCE
!*****************************************************************************
module pao_plain_rot_tests
use cp_log_handling, only: cp_to_string, cp_failure_level, cp_warning_level,&
cp_log, cp_logger_type, cp_note_level
use cp_error_handling, only: cp_error_type, cp_assert, cp_error_message,&
cp_assertion_failed, cp_debug, cp_precondition_failed, cp_error_init,&
cp_error_dealloc_ref, cp_error_get_logger
use kinds, only: wp=>dp
use pao_utils, only: cp_get_random_integer
use cp_matrix_utils, only: cp_sup_norm_matrix
use mathconstants, only: pi
use global_types, only: global_environment_type
use pao_plain_rot, only: cp_right_compose_p_rot, &
cp_right_compose_p_rot_deriv, cp_left_compose_p_rot,&
cp_left_compose_p_rot_deriv
use pao_types, only: pao_env_type, pao_glob_angles_type
use pao_types_tests, only: cp_init_test_pao_env
use pao_l_angles_methods, only: pao_local_angles_type, cp_init, &
cp_dealloc_ref, cp_get
use cp_array_utils, only: cp_2d_r_output
implicit none
private
MODULE pao_plain_rot_tests
USE cp_array_utils, ONLY: cp_2d_r_output
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_debug,&
cp_error_dealloc_ref,&
cp_error_get_logger,&
cp_error_init,&
cp_error_message,&
cp_error_type,&
cp_precondition_failed
USE cp_log_handling, ONLY: cp_failure_level,&
cp_log,&
cp_logger_type,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE cp_matrix_utils, ONLY: cp_sup_norm_matrix
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE mathconstants, ONLY: pi
USE pao_l_angles_methods, ONLY: cp_dealloc_ref,&
cp_get,&
cp_init,&
pao_local_angles_type
USE pao_plain_rot, ONLY: cp_left_compose_p_rot,&
cp_left_compose_p_rot_deriv,&
cp_right_compose_p_rot,&
cp_right_compose_p_rot_deriv
USE pao_types, ONLY: pao_env_type,&
pao_glob_angles_type
USE pao_types_tests, ONLY: cp_init_test_pao_env
USE pao_utils, ONLY: cp_get_random_integer
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
public :: pao_test_plain_rot, pao_test_u_du
PUBLIC :: pao_test_plain_rot, pao_test_u_du
!!***
!******************************************************************************
contains
CONTAINS
!!****f* pao_plain_rot_tests/pao_test_plain_rot [1.0] *
!!
@ -86,219 +100,219 @@ contains
!! none
!!
!!*** ************************************************************************
subroutine pao_test_plain_rot(g_env, failed, error)
type(global_environment_type), intent(in), target ::g_env
logical, intent(inout) :: failed
type(cp_error_type), optional, intent(inout):: error
SUBROUTINE pao_test_plain_rot(g_env, failed, error)
TYPE(global_environment_type), INTENT(in), TARGET ::g_env
LOGICAL, INTENT(inout) :: failed
TYPE(cp_error_type), OPTIONAL, INTENT(inout):: error
logical :: failure
character(len=*), parameter :: routineP='cp_plain_rot_tests:cp_test_plain_rot'
integer, parameter :: n=10
integer :: i,j
real(kind=wp) :: m1(n,n),m2(n,n),tmpV1(n), angle, err
type(cp_logger_type), pointer :: logger
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineP='cp_plain_rot_tests:cp_test_plain_rot'
INTEGER, PARAMETER :: n=10
INTEGER :: i,j
REAL(kind=wp) :: m1(n,n),m2(n,n),tmpV1(n), angle, err
TYPE(cp_logger_type), POINTER :: logger
failure=.FALSE.
CPPrecondition(n>1,cp_failure_level,routineP,error,failure)
if (.NOT. failure) then
IF (.NOT. failure) THEN
logger=>cp_error_get_logger(error)
i=cp_get_random_integer(from=1,to=n)
j=cp_get_random_integer(from=1,to=n)
if (i==j) then
if (i>1) then
IF (i==j) THEN
IF (i>1) THEN
j=i-1
else
ELSE
j=i+1
end if
end if
call random_number(m1)
END IF
END IF
CALL RANDOM_NUMBER(m1)
m2=m1
! t1r
if (cp_debug.and.debug_this_module) then
call cp_log(logger,cp_note_level,routineP, &
IF (cp_debug.and.debug_this_module) THEN
CALL cp_log(logger,cp_note_level,routineP, &
'test1r: rotation with pi/2 swaps columns and change sign of the second')
end if
END IF
tmpV1=m2(:,i)
m2(:,i)=m2(:,j)
m2(:,j)=-tmpV1
call cp_right_compose_p_rot(m1,pi/2,i,j)
CALL cp_right_compose_p_rot(m1,pi/2,i,j)
err=cp_sup_norm_matrix(m2-m1)
if (err>10*epsilon(0.0_wp)) then
failure=.true.
call cp_log(logger,cp_failure_level,routineP, &
IF (err>10*EPSILON(0.0_wp)) THEN
failure=.TRUE.
CALL cp_log(logger,cp_failure_level,routineP, &
'test1r (right rot pi/2) with i='//cp_to_string(i)// &
' j='//cp_to_string(j)//' failed')
else if (cp_debug .and. debug_this_module) then
call cp_log(logger,cp_warning_level,routineP,&
ELSE IF (cp_debug .AND. debug_this_module) THEN
CALL cp_log(logger,cp_warning_level,routineP,&
'test1r: SUCCESS')
end if
END IF
! t2r
if (cp_debug.and.debug_this_module) then
call cp_log(logger,cp_note_level,routineP, &
IF (cp_debug.and.debug_this_module) THEN
CALL cp_log(logger,cp_note_level,routineP, &
'test2r: rotation with -angle restores the matrix')
end if
END IF
m2=m1
call random_number(angle)
CALL RANDOM_NUMBER(angle)
angle=4.0_wp*pi*angle
call cp_right_compose_p_rot(m1,angle,i,j)
call cp_right_compose_p_rot(m1,-angle,i,j)
CALL cp_right_compose_p_rot(m1,angle,i,j)
CALL cp_right_compose_p_rot(m1,-angle,i,j)
err=cp_sup_norm_matrix(m2-m1)
if (err>2*n*epsilon(0.0_wp)) then
failure=.true.
call cp_log(logger,cp_failure_level,routineP, &
IF (err>2*n*EPSILON(0.0_wp)) THEN
failure=.TRUE.
CALL cp_log(logger,cp_failure_level,routineP, &
'test2r (right -angle = rot^-1) with angle='//cp_to_string(angle)&
//' i='//cp_to_string(i)// &
' j='//cp_to_string(j)//' failed')
else if (cp_debug .and. debug_this_module) then
call cp_log(logger,cp_warning_level,routineP,&
ELSE IF (cp_debug .AND. debug_this_module) THEN
CALL cp_log(logger,cp_warning_level,routineP,&
'test2r: SUCCESS')
end if
END IF
!t1l
if (cp_debug.and.debug_this_module) then
call cp_log(logger,cp_note_level,routineP, &
IF (cp_debug.and.debug_this_module) THEN
CALL cp_log(logger,cp_note_level,routineP, &
'test1l: rotation with pi/2 swaps lines and change sign of the first')
end if
END IF
tmpV1=m2(i,:)
m2(i,:)=-m2(j,:)
m2(j,:)=tmpV1
call cp_left_compose_p_rot(m1,pi/2,i,j)
CALL cp_left_compose_p_rot(m1,pi/2,i,j)
err=cp_sup_norm_matrix(m2-m1)
if (err>2*n*epsilon(0.0_wp)) then
failure=.true.
call cp_log(logger,cp_failure_level,routineP, &
IF (err>2*n*EPSILON(0.0_wp)) THEN
failure=.TRUE.
CALL cp_log(logger,cp_failure_level,routineP, &
'test1l (right rot pi/2) with i='//cp_to_string(i)// &
' j='//cp_to_string(j)//' failed')
else if (cp_debug .and. debug_this_module) then
call cp_log(logger,cp_warning_level,routineP,&
ELSE IF (cp_debug .AND. debug_this_module) THEN
CALL cp_log(logger,cp_warning_level,routineP,&
'test1l: SUCCESS')
end if
END IF
! t2l
if (cp_debug.and.debug_this_module) then
call cp_log(logger,cp_note_level,routineP, &
IF (cp_debug.and.debug_this_module) THEN
CALL cp_log(logger,cp_note_level,routineP, &
'test2l: rotation with -angle restores the matrix')
end if
END IF
m2=m1
call random_number(angle)
CALL RANDOM_NUMBER(angle)
angle=4.0_wp*pi*angle
call cp_left_compose_p_rot(m1,angle,i,j)
call cp_left_compose_p_rot(m1,-angle,i,j)
CALL cp_left_compose_p_rot(m1,angle,i,j)
CALL cp_left_compose_p_rot(m1,-angle,i,j)
err=cp_sup_norm_matrix(m2-m1)
if (err>2*n*epsilon(0.0_wp)) then
failure=.true.
call cp_log(logger,cp_failure_level,routineP, &
IF (err>2*n*EPSILON(0.0_wp)) THEN
failure=.TRUE.
CALL cp_log(logger,cp_failure_level,routineP, &
'test2l (right -angle = rot^-1) with angle='//cp_to_string(angle)&
//' i='//cp_to_string(i)// &
' j='//cp_to_string(j)//' failed')
else if (cp_debug .and. debug_this_module) then
call cp_log(logger,cp_warning_level,routineP,&
ELSE IF (cp_debug .AND. debug_this_module) THEN
CALL cp_log(logger,cp_warning_level,routineP,&
'test2l: SUCCESS')
end if
END IF
! t3
if (cp_debug.and.debug_this_module) then
call cp_log(logger,cp_note_level,routineP, &
IF (cp_debug.and.debug_this_module) THEN
CALL cp_log(logger,cp_note_level,routineP, &
'test3: the unit matrix is the same in all orthonormal basis')
end if
END IF
m1=0
forall (i=1:n) m1(i,i)=1
FORALL (i=1:n) m1(i,i)=1
m2=m1
call random_number(angle)
CALL RANDOM_NUMBER(angle)
angle=4.0_wp*pi*angle
call cp_left_compose_p_rot(m1,angle,i,j)
call cp_right_compose_p_rot(m1,-angle,i,j)
CALL cp_left_compose_p_rot(m1,angle,i,j)
CALL cp_right_compose_p_rot(m1,-angle,i,j)
err=cp_sup_norm_matrix(m2-m1)
if (err>2*n*epsilon(0.0_wp)) then
failure=.true.
call cp_log(logger,cp_failure_level,routineP, &
IF (err>2*n*EPSILON(0.0_wp)) THEN
failure=.TRUE.
CALL cp_log(logger,cp_failure_level,routineP, &
'test3 (unity matrix same in all ONB) with angle='//cp_to_string(angle)&
//' i='//cp_to_string(i)// &
' j='//cp_to_string(j)//' failed')
if (cp_debug .and. debug_this_module) then
call cp_2d_r_output(logger, 'identity_matrix', routineP,1,m1,'identity matrix')
end if
else if (cp_debug .and. debug_this_module) then
call cp_log(logger,cp_warning_level,routineP,&
IF (cp_debug .AND. debug_this_module) THEN
CALL cp_2d_r_output(logger, 'identity_matrix', routineP,1,m1,'identity matrix')
END IF
ELSE IF (cp_debug .AND. debug_this_module) THEN
CALL cp_log(logger,cp_warning_level,routineP,&
'test3: SUCCESS')
end if
END IF
! t4
if (cp_debug.and.debug_this_module) then
call cp_log(logger,cp_note_level,routineP, &
IF (cp_debug.and.debug_this_module) THEN
CALL cp_log(logger,cp_note_level,routineP, &
'test4: d/dt (J(t,i,j)J(-t,i,j)M)=0')
end if
END IF
! test m1 = identity
!m1=0
!forall (i=1:n) m1(i,i)=1
call random_number(m1)
CALL RANDOM_NUMBER(m1)
m2=m1
call random_number(angle)
CALL RANDOM_NUMBER(angle)
angle=4.0_wp*pi*angle
call cp_left_compose_p_rot(m1,-angle,i,j)
CALL cp_left_compose_p_rot(m1,-angle,i,j)
!call cp_2d_r_output(logger, 'm1_1', routineP,1,m1,'m1.1')
call cp_left_compose_p_rot_deriv(m1,angle,i,j)
CALL cp_left_compose_p_rot_deriv(m1,angle,i,j)
!call cp_2d_r_output(logger, 'm1_2', routineP,1,m1,'m1.2')
call cp_left_compose_p_rot_deriv(m2,-angle,i,j)
CALL cp_left_compose_p_rot_deriv(m2,-angle,i,j)
!call cp_2d_r_output(logger, 'm2_1', routineP,1,m2,'m2.1')
call cp_left_compose_p_rot(m2,angle,i,j)
CALL cp_left_compose_p_rot(m2,angle,i,j)
!call cp_2d_r_output(logger, 'm2_2', routineP,1,m2,'m2.2')
err=cp_sup_norm_matrix(m1-m2)
if (err>2*n*epsilon(0.0_wp)) then
failure=.true.
call cp_log(logger,cp_failure_level,routineP, &
IF (err>2*n*EPSILON(0.0_wp)) THEN
failure=.TRUE.
CALL cp_log(logger,cp_failure_level,routineP, &
'test4 d/dt (J(t,i,j)J(-t,i,j)M)=0 with angle='//cp_to_string(angle)&
//' i='//cp_to_string(i)// &
' j='//cp_to_string(j)//' failed')
if (cp_debug .and. debug_this_module) then
call cp_2d_r_output(logger, 'zero_matrix', routineP,1,m1-m2,'zero matrix 1')
end if
else if (cp_debug .and. debug_this_module) then
call cp_log(logger,cp_warning_level,routineP,&
IF (cp_debug .AND. debug_this_module) THEN
CALL cp_2d_r_output(logger, 'zero_matrix', routineP,1,m1-m2,'zero matrix 1')
END IF
ELSE IF (cp_debug .AND. debug_this_module) THEN
CALL cp_log(logger,cp_warning_level,routineP,&
'test4: SUCCESS')
end if
END IF
! t5
if (cp_debug.and.debug_this_module) then
call cp_log(logger,cp_note_level,routineP, &
IF (cp_debug.and.debug_this_module) THEN
CALL cp_log(logger,cp_note_level,routineP, &
'test5: d/dt (MJ(t,i,j)J(-t,i,j))=0')
end if
call random_number(m1)
END IF
CALL RANDOM_NUMBER(m1)
m2=m1
call random_number(angle)
CALL RANDOM_NUMBER(angle)
angle=4.0_wp*pi*angle
call cp_right_compose_p_rot(m1,-angle,i,j)
call cp_right_compose_p_rot_deriv(m1,angle,i,j)
call cp_right_compose_p_rot_deriv(m2,-angle,i,j)
call cp_right_compose_p_rot(m2,angle,i,j)
CALL cp_right_compose_p_rot(m1,-angle,i,j)
CALL cp_right_compose_p_rot_deriv(m1,angle,i,j)
CALL cp_right_compose_p_rot_deriv(m2,-angle,i,j)
CALL cp_right_compose_p_rot(m2,angle,i,j)
err=cp_sup_norm_matrix(m1-m2)
if (err>2*n*epsilon(0.0_wp)) then
failure=.true.
call cp_log(logger,cp_failure_level,routineP, &
IF (err>2*n*EPSILON(0.0_wp)) THEN
failure=.TRUE.
CALL cp_log(logger,cp_failure_level,routineP, &
'test5 d/dt (M J(t,i,j)J(-t,i,j))=0 with angle='//cp_to_string(angle)&
//' i='//cp_to_string(i)// &
' j='//cp_to_string(j)//' failed')
if (cp_debug .and. debug_this_module) then
call cp_2d_r_output(logger, 'zero_matrix', routineP,2,m1-m2,'zero matrix 2')
end if
else if (cp_debug .and. debug_this_module) then
call cp_log(logger,cp_warning_level,routineP,&
IF (cp_debug .AND. debug_this_module) THEN
CALL cp_2d_r_output(logger, 'zero_matrix', routineP,2,m1-m2,'zero matrix 2')
END IF
ELSE IF (cp_debug .AND. debug_this_module) THEN
CALL cp_log(logger,cp_warning_level,routineP,&
'test5: SUCCESS')
end if
END IF
! u_du tests
if (.not.pao_test_u_du(g_env,error=error)) then
failure=.true.
end if
IF (.not.pao_test_u_du(g_env,error=error)) THEN
failure=.TRUE.
END IF
if (cp_debug .and. debug_this_module .and. .not.failure) then
call cp_log(logger,cp_warning_level,routineP,&
IF (cp_debug .AND. debug_this_module .AND. .not.failure) THEN
CALL cp_log(logger,cp_warning_level,routineP,&
'cp_test_plain_rot: all tests succeded, SUCCESS')
end if
end if
end subroutine pao_test_plain_rot
END IF
END IF
END SUBROUTINE pao_test_plain_rot
!******************************************************************************
!!****f* pao_test_plain_rot/pao_test_u_du [1.0] *
@ -332,23 +346,23 @@ contains
!! none
!!
!!*** **********************************************************************
function pao_test_u_du(glob_env,error) result(res)
logical ::res
type(global_environment_type), target :: glob_env
type(cp_error_type), optional, intent(inout) :: error
FUNCTION pao_test_u_du(glob_env,error) RESULT(res)
LOGICAL ::res
TYPE(global_environment_type), TARGET :: glob_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineP='pao_plain_rot_tests:pao_test_u_du'
integer, parameter :: n_atom=3, atom_nr=1
type(pao_env_type) :: pao_env
type(pao_glob_angles_type), pointer :: g_angles
type(pao_local_angles_type) :: l_angles
real(kind=wp), dimension(:), pointer :: angles
real(kind=wp),dimension(:,:), allocatable :: m1,m2,m3
real(kind=wp) :: err
integer :: stat, full_bas_size, i
type(cp_logger_type), pointer :: logger
failure=.false.
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineP='pao_plain_rot_tests:pao_test_u_du'
INTEGER, PARAMETER :: n_atom=3, atom_nr=1
TYPE(pao_env_type) :: pao_env
TYPE(pao_glob_angles_type), POINTER :: g_angles
TYPE(pao_local_angles_type) :: l_angles
REAL(kind=wp), DIMENSION(:), POINTER :: angles
REAL(kind=wp),DIMENSION(:,:), ALLOCATABLE :: m1,m2,m3
REAL(kind=wp) :: err
INTEGER :: stat, full_bas_size, i
TYPE(cp_logger_type), POINTER :: logger
failure=.FALSE.
logger=>cp_error_get_logger(error)
!!FM call cp_init_test_pao_env(pao_env,glob_env,n_atom,error=error)
@ -396,8 +410,8 @@ contains
!!FM call cp_dealloc_ref(l_angles,error=error)
!!FM call cp_dealloc_ref(pao_env,error=error)
res=failure
end function pao_test_u_du
END FUNCTION pao_test_u_du
!***************************************************************************
end module pao_plain_rot_tests
END MODULE pao_plain_rot_tests

909
src/pao_proj_methods.F
View file

File diff suppressed because it is too large Load diff

215
src/pao_types.F
View file

@ -28,48 +28,61 @@
!!
!! SOURCE
!*****************************************************************************
module pao_types
use cp_log_handling, only: cp_to_string, cp_failure_level, cp_warning_level,&
cp_note_level
use cp_error_handling, only: cp_debug, cp_error_type, cp_assert, &
cp_error_message
use kinds, only: wp=>dp
use sparse_matrix_types, only: real_matrix_type, replicate_matrix, copy_matrix,&
allocate_matrix, deallocate_matrix, get_matrix_info, get_block_node,&
add_block_node, put_block_node
use global_types, only: global_environment_type
use cp_block_matrix, only: cp_block_matrix_type,cp_block_matrix_p_type,&
cp_sp_create
use cp_b_matrix_structure, only: cp_b_matrix_struct_type, cp_get
use pao_bas_projection_types, only: pao_bas_projection_type, cp_get
implicit none
private
MODULE pao_types
USE cp_b_matrix_structure, ONLY: cp_b_matrix_struct_type,&
cp_get
USE cp_block_matrix, ONLY: cp_block_matrix_p_type,&
cp_block_matrix_type,&
cp_sp_create
USE cp_error_handling, ONLY: cp_assert,&
cp_debug,&
cp_error_message,&
cp_error_type
USE cp_log_handling, ONLY: cp_failure_level,&
cp_note_level,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp=>dp
USE pao_bas_projection_types, ONLY: cp_get,&
pao_bas_projection_type
USE sparse_matrix_types, ONLY: add_block_node,&
allocate_matrix,&
copy_matrix,&
deallocate_matrix,&
get_block_node,&
get_matrix_info,&
put_block_node,&
real_matrix_type,&
replicate_matrix
IMPLICIT NONE
PRIVATE
logical, private, parameter :: debug_this_module=.true.
character(len=*), private, parameter :: moduleN='pao_types'
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='pao_types'
! =========== public objects ==========
! types
public :: pao_env_type, pao_glob_angles_type
PUBLIC :: pao_env_type, pao_glob_angles_type
! pao_env procedures
public :: cp_get, cp_valid
PUBLIC :: cp_get, cp_valid
! underlying functions
public :: pao_env_get, pao_env_valid
PUBLIC :: pao_env_get, pao_env_valid
!! gets values from the first argument via optional keyword arguments
!! that depend on the type of the first argument
interface cp_get
module procedure pao_env_get
end interface
INTERFACE cp_get
MODULE PROCEDURE pao_env_get
END INTERFACE
!! returns true if the first argument is valid. Only a fast minimal
!! validation is performed (no dangling pointers)
interface cp_valid
module procedure pao_env_valid
end interface
INTERFACE cp_valid
MODULE PROCEDURE pao_env_valid
END INTERFACE
!!***
!****************************************************************************
@ -122,15 +135,15 @@ module pao_types
!!
!! SOURCE
!***************************************************************************
type pao_glob_angles_type
TYPE pao_glob_angles_type
!private
logical :: initialized, m_s_m_valid, m_h_m_valid
real(kind=wp), dimension(:), pointer :: angles
logical, dimension(:), pointer :: ut_calculated, NUi_injection_calculated
type(cp_block_matrix_type), pointer :: unitary_t, NUi_injection
type(cp_block_matrix_p_type), dimension(:), pointer :: min_overlap_m
type(cp_block_matrix_p_type), dimension(:), pointer :: min_hamiltonian_m
end type pao_glob_angles_type
LOGICAL :: initialized, m_s_m_valid, m_h_m_valid
REAL(kind=wp), DIMENSION(:), POINTER :: angles
LOGICAL, DIMENSION(:), POINTER :: ut_calculated, NUi_injection_calculated
TYPE(cp_block_matrix_type), POINTER :: unitary_t, NUi_injection
TYPE(cp_block_matrix_p_type), DIMENSION(:), POINTER :: min_overlap_m
TYPE(cp_block_matrix_p_type), DIMENSION(:), POINTER :: min_hamiltonian_m
END TYPE pao_glob_angles_type
!!***
!****************************************************************************
@ -178,27 +191,27 @@ module pao_types
!!
!! SOURCE
!***************************************************************************
type pao_env_type
TYPE pao_env_type
! private
logical :: initialized ! =.false.
logical :: min_d_m_valid
logical, dimension(:), pointer :: atomic_ortho_valid
real(kind=wp) :: wanted_subspace_pos_precision
real(kind=wp) :: wanted_in_subspace_precision
integer, dimension(:), pointer :: angles_begin_at ! private
integer :: max_min_bas,max_full_bas,max_excl_bas,tot_min_bas,&
LOGICAL :: initialized ! =.false.
LOGICAL :: min_d_m_valid
LOGICAL, DIMENSION(:), POINTER :: atomic_ortho_valid
REAL(kind=wp) :: wanted_subspace_pos_precision
REAL(kind=wp) :: wanted_in_subspace_precision
INTEGER, DIMENSION(:), POINTER :: angles_begin_at ! private
INTEGER :: max_min_bas,max_full_bas,max_excl_bas,tot_min_bas,&
tot_full_bas, tot_excl_bas, max_l_angles
type(pao_glob_angles_type), pointer :: angles_att
type(cp_block_matrix_p_type), dimension(:), pointer :: min_density_m
type(cp_b_matrix_struct_type), pointer :: min_bas_m_struct, &
TYPE(pao_glob_angles_type), POINTER :: angles_att
TYPE(cp_block_matrix_p_type), DIMENSION(:), POINTER :: min_density_m
TYPE(cp_b_matrix_struct_type), POINTER :: min_bas_m_struct, &
full_bas_m_struct, full_min_bas_m_struct, min_full_bas_m_struct,&
full_bas_diag_m_struct
type(cp_block_matrix_type), pointer :: atomic_ortho
end type pao_env_type
TYPE(cp_block_matrix_type), POINTER :: atomic_ortho
END TYPE pao_env_type
!!***
!***************************************************************************
contains
CONTAINS
! ================== pao_env_type === get methods ===================
@ -253,46 +266,46 @@ contains
!!
!! SOURCE
!!*** **********************************************************************
subroutine pao_env_get(pao_env, wanted_subspace_pos_precision,&
SUBROUTINE pao_env_get(pao_env, wanted_subspace_pos_precision,&
wanted_in_subspace_precision, angles_att,min_density_m, &
min_bas_m_struct, full_bas_m_struct, full_min_bas_m_struct, &
min_full_bas_m_struct, full_bas_diag_m_struct,error)
type(pao_env_type), target, intent(in) :: pao_env
real(kind=wp), optional, intent(out) :: wanted_subspace_pos_precision
real(kind=wp), optional, intent(out) :: wanted_in_subspace_precision
type(pao_glob_angles_type), optional, pointer :: angles_att
type(cp_block_matrix_p_type), dimension(:), optional, pointer ::&
TYPE(pao_env_type), TARGET, INTENT(in) :: pao_env
REAL(kind=wp), OPTIONAL, INTENT(out) :: wanted_subspace_pos_precision
REAL(kind=wp), OPTIONAL, INTENT(out) :: wanted_in_subspace_precision
TYPE(pao_glob_angles_type), OPTIONAL, POINTER :: angles_att
TYPE(cp_block_matrix_p_type), DIMENSION(:), OPTIONAL, POINTER ::&
min_density_m
type(cp_b_matrix_struct_type), pointer, optional :: min_bas_m_struct, &
TYPE(cp_b_matrix_struct_type), POINTER, OPTIONAL :: min_bas_m_struct, &
full_bas_m_struct, full_min_bas_m_struct, min_full_bas_m_struct,&
full_bas_diag_m_struct
type(cp_error_type), optional, intent(inout) :: error
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='pao_env_get',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='pao_env_get',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
CPPrecondition(pao_env%initialized, cp_failure_level,routineP,error,failure)
if (.not. failure) then
if (present(wanted_subspace_pos_precision)) &
IF (.NOT. failure) THEN
IF (PRESENT(wanted_subspace_pos_precision)) &
wanted_subspace_pos_precision=pao_env%wanted_subspace_pos_precision
if (present(wanted_in_subspace_precision)) &
IF (PRESENT(wanted_in_subspace_precision)) &
wanted_in_subspace_precision=pao_env%wanted_in_subspace_precision
if (present(angles_att)) angles_att => pao_env%angles_att
if (present(min_density_m)) min_density_m => pao_env%min_density_m
if (present(min_bas_m_struct)) &
IF (PRESENT(angles_att)) angles_att => pao_env%angles_att
IF (PRESENT(min_density_m)) min_density_m => pao_env%min_density_m
IF (PRESENT(min_bas_m_struct)) &
min_bas_m_struct => pao_env%min_bas_m_struct
if (present(full_bas_m_struct)) &
IF (PRESENT(full_bas_m_struct)) &
full_bas_m_struct => pao_env%full_bas_m_struct
if (present(full_min_bas_m_struct)) &
IF (PRESENT(full_min_bas_m_struct)) &
full_min_bas_m_struct => pao_env%full_min_bas_m_struct
if (present(min_full_bas_m_struct)) &
IF (PRESENT(min_full_bas_m_struct)) &
min_full_bas_m_struct => pao_env%min_full_bas_m_struct
if (present(full_bas_diag_m_struct)) &
IF (PRESENT(full_bas_diag_m_struct)) &
full_bas_diag_m_struct => pao_env%full_bas_diag_m_struct
end if
end subroutine pao_env_get
END IF
END SUBROUTINE pao_env_get
!***************************************************************************
!!****f* pao_env_methods/pao_env_valid [1.0] *
@ -326,39 +339,39 @@ contains
!! 1.2002 created [fawzi]
!!
!!*** **********************************************************************
function pao_env_valid(pao_env,error) result(res)
logical ::res
type(pao_env_type), intent(in) :: pao_env
type(cp_error_type), optional, intent(inout) :: error
FUNCTION pao_env_valid(pao_env,error) RESULT(res)
LOGICAL ::res
TYPE(pao_env_type), INTENT(in) :: pao_env
TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error
logical :: failure
character(len=*), parameter :: routineN='pao_env_valid',&
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineN='pao_env_valid',&
routineP=moduleN//':'//routineN
failure=.false.
failure=.FALSE.
CPPrecondition(pao_env%initialized,cp_failure_level,routineP,error,failure)
if (.not. failure) then
if (.not.(associated(pao_env%angles_begin_at).and.&
associated(pao_env%full_min_bas_m_struct).and.&
associated(pao_env%full_bas_diag_m_struct).and.&
associated(pao_env%full_bas_m_struct).and.&
associated(pao_env%min_full_bas_m_struct).and.&
associated(pao_env%min_bas_m_struct).and.&
(.not.associated(pao_env%atomic_ortho).or.&
associated(pao_env%atomic_ortho_valid)))) then
CPAssert(associated(pao_env%angles_begin_at),cp_warning_level,routineP,error,failure)
CPAssert(associated(pao_env%full_min_bas_m_struct),cp_warning_level,routineP,error,failure)
CPAssert(associated(pao_env%full_bas_diag_m_struct),cp_warning_level,routineP,error,failure)
CPAssert(associated(pao_env%full_bas_m_struct),cp_warning_level,routineP,error,failure)
CPAssert(associated(pao_env%min_full_bas_m_struct),cp_warning_level,routineP,error,failure)
CPAssert(associated(pao_env%min_bas_m_struct),cp_warning_level,routineP,error,failure)
if (associated(pao_env%atomic_ortho)) then
CPAssert(associated(pao_env%atomic_ortho_valid),cp_warning_level,routineP,error,failure)
end if
end if
end if
IF (.NOT. failure) THEN
IF (.NOT.(ASSOCIATED(pao_env%angles_begin_at).AND.&
ASSOCIATED(pao_env%full_min_bas_m_struct).AND.&
ASSOCIATED(pao_env%full_bas_diag_m_struct).AND.&
ASSOCIATED(pao_env%full_bas_m_struct).AND.&
ASSOCIATED(pao_env%min_full_bas_m_struct).AND.&
ASSOCIATED(pao_env%min_bas_m_struct).AND.&
(.not.ASSOCIATED(pao_env%atomic_ortho).OR.&
ASSOCIATED(pao_env%atomic_ortho_valid)))) THEN
CPAssert(ASSOCIATED(pao_env%angles_begin_at),cp_warning_level,routineP,error,failure)
CPAssert(ASSOCIATED(pao_env%full_min_bas_m_struct),cp_warning_level,routineP,error,failure)
CPAssert(ASSOCIATED(pao_env%full_bas_diag_m_struct),cp_warning_level,routineP,error,failure)
CPAssert(ASSOCIATED(pao_env%full_bas_m_struct),cp_warning_level,routineP,error,failure)
CPAssert(ASSOCIATED(pao_env%min_full_bas_m_struct),cp_warning_level,routineP,error,failure)
CPAssert(ASSOCIATED(pao_env%min_bas_m_struct),cp_warning_level,routineP,error,failure)
IF (ASSOCIATED(pao_env%atomic_ortho)) THEN
CPAssert(ASSOCIATED(pao_env%atomic_ortho_valid),cp_warning_level,routineP,error,failure)
END IF
END IF
END IF
res=.not.failure
end function pao_env_valid
END FUNCTION pao_env_valid
!***************************************************************************
! ==================== pao_glob_angles_type ====================
@ -367,5 +380,5 @@ contains
! ======================= pao_bas_proj =====================
end module pao_types
END MODULE pao_types

82
src/pao_utils.F
View file

@ -25,24 +25,28 @@
!!
!! SOURCE
!*****************************************************************************
module pao_utils
use cp_log_handling, only: cp_to_string, cp_failure_level, cp_warning_level
use cp_error_handling, only: cp_error_type, cp_assert, cp_error_message,&
cp_assertion_failed
use kinds, only: wp => dp
use global_types, only: global_environment_type
use sparse_matrix_types
use message_passing, only: mp_sum
implicit none
private
logical, private, parameter :: debug_this_module=.true.
character(len=*), parameter :: moduleN='pao_utils'
MODULE pao_utils
USE cp_error_handling, ONLY: cp_assert,&
cp_assertion_failed,&
cp_error_message,&
cp_error_type
USE cp_log_handling, ONLY: cp_failure_level,&
cp_to_string,&
cp_warning_level
USE global_types, ONLY: global_environment_type
USE kinds, ONLY: wp => dp
USE message_passing, ONLY: mp_sum
USE sparse_matrix_types
IMPLICIT NONE
PRIVATE
LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE.
CHARACTER(len=*), PARAMETER :: moduleN='pao_utils'
! =========== public objects ==========
! types
! procedures
public :: cp_get_random_integer
PUBLIC :: cp_get_random_integer
! ============== interfaces ===========
@ -51,7 +55,7 @@ module pao_utils
!****************************************************************************
contains
CONTAINS
!!****f* pao_utils/cp_get_random_integer [1.0] *
!!
@ -88,45 +92,45 @@ contains
!! SOURCE
!****************************************************************************
!pure
function cp_get_random_integer(from,to,error) result(res)
integer :: res
integer, optional, intent(in) :: from, to
type(cp_error_type), optional, intent(in) :: error
FUNCTION cp_get_random_integer(from,to,error) RESULT(res)
INTEGER :: res
INTEGER, OPTIONAL, INTENT(in) :: from, to
TYPE(cp_error_type), OPTIONAL, INTENT(in) :: error
logical :: failure
character(len=*), parameter :: routineP='util:cp_get_random_integer'
real :: rand
integer :: fromi, toi
type(cp_error_type) :: iError
LOGICAL :: failure
CHARACTER(len=*), PARAMETER :: routineP='util:cp_get_random_integer'
REAL :: rand
INTEGER :: fromi, toi
TYPE(cp_error_type) :: iError
failure=.FALSE.
!call cp_init(iError,template_error=error)
if (.not. present(from)) then
IF (.NOT. PRESENT(from)) THEN
fromi=1
else
ELSE
fromi=from
end if
if (.not. present(to)) then
END IF
IF (.NOT. PRESENT(to)) THEN
toi=100
else
ELSE
toi=to
end if
END IF
!CPPrecondition(fromi<=toi,cp_failure_level,routineP,iError,failure)
if (.not.fromi<=toi) failure=.true.
if (.NOT. failure) then
call random_number(rand)
res=fromi+floor(rand*real(toi-fromi+1))
IF (.not.fromi<=toi) failure=.TRUE.
IF (.NOT. failure) THEN
CALL RANDOM_NUMBER(rand)
res=fromi+FLOOR(rand*REAL(toi-fromi+1))
!CPPostcondition(res<=toi.and.res>=fromi,cp_warning_level,routineP,iError,failure)
if (res>toi) res=toi
if (res<fromi) res=fromi
else
IF (res>toi) res=toi
IF (res<fromi) res=fromi
ELSE
res=-1
end if
END IF
!call cp_dealloc_ref(iError,error=error)
end function cp_get_random_integer
END FUNCTION cp_get_random_integer
!!***
!****************************************************************************
end module pao_utils
END MODULE pao_utils