From 3bd4f05710fe34b70b24c1011b4690cea8a2f4c0 Mon Sep 17 00:00:00 2001 From: Mohamed Fawzi Date: Fri, 22 Nov 2002 11:28:21 +0000 Subject: [PATCH] prettied cp_* pao_* svn-origin-rev: 993 --- src/cp_array_i_utils.F | 57 +- src/cp_array_logical_utils.F | 57 +- src/cp_array_r_utils.F | 57 +- src/cp_array_utils.F | 11 +- src/cp_b_matrix_structure.F | 1103 +++++++-------- src/cp_blacs_env.F | 235 ++-- src/cp_block_matrix.F | 1150 ++++++++-------- src/cp_e_rosenbrok_function.F | 198 +-- src/cp_error_handling.F | 14 +- src/cp_fm_basic_linalg.F | 8 +- src/cp_fm_cholesky.F | 30 +- src/cp_fm_pool_types.F | 6 +- src/cp_fm_struct.F | 8 +- src/cp_fm_types.F | 6 +- src/cp_fm_utils.F | 8 +- src/cp_fm_vect.F | 4 +- src/cp_lbfgs.F | 2201 +++++++++++++++--------------- src/cp_lbfgs_optimizer_e_rosen.F | 42 +- src/cp_lbfgs_optimizer_gerd_f.F | 42 +- src/cp_lbfgs_optimizer_tests.F | 123 +- src/cp_linked_list_int_ptr.F | 98 +- src/cp_log_handling.F | 14 +- src/cp_matrix_utils.F | 1092 +++++++-------- src/cp_output_handling.F | 27 +- src/cp_para_types.F | 44 +- src/cp_sll_int_ptr_tests.F | 139 +- src/cp_sll_int_tests.F | 139 +- src/cp_sp_iterators.F | 244 ++-- src/pao_bas_projection_types.F | 486 +++---- src/pao_env_methods.F | 476 ++++--- src/pao_glob_angles_methods.F | 900 ++++++------ src/pao_plain_rot.F | 181 +-- src/pao_plain_rot_tests.F | 340 ++--- src/pao_proj_methods.F | 909 ++++++------ src/pao_types.F | 215 +-- src/pao_utils.F | 82 +- 36 files changed, 5534 insertions(+), 5212 deletions(-) diff --git a/src/cp_array_i_utils.F b/src/cp_array_i_utils.F index f3efaa2f6f..c2c92cc6eb 100644 --- a/src/cp_array_i_utils.F +++ b/src/cp_array_i_utils.F @@ -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 diff --git a/src/cp_array_logical_utils.F b/src/cp_array_logical_utils.F index 8bc16782d6..8081f05cfb 100644 --- a/src/cp_array_logical_utils.F +++ b/src/cp_array_logical_utils.F @@ -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 diff --git a/src/cp_array_r_utils.F b/src/cp_array_r_utils.F index 75362e7fa7..4fd550750e 100644 --- a/src/cp_array_r_utils.F +++ b/src/cp_array_r_utils.F @@ -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 diff --git a/src/cp_array_utils.F b/src/cp_array_utils.F index 2dbf055aa8..55dc94034c 100644 --- a/src/cp_array_utils.F +++ b/src/cp_array_utils.F @@ -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 diff --git a/src/cp_b_matrix_structure.F b/src/cp_b_matrix_structure.F index f2e8fbab2d..84c74675d2 100644 --- a/src/cp_b_matrix_structure.F +++ b/src/cp_b_matrix_structure.F @@ -27,33 +27,46 @@ !! !! SOURCE !**************************************************************************** -module cp_b_matrix_structure - 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 timings, only: timeset, timestop - use message_passing, only: mp_sum - use cp_para_types, only: cp_para_env_type - use cp_para_env, only: cp_para_env_retain, cp_para_env_release - implicit none - private +MODULE cp_b_matrix_structure + 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_para_env, ONLY: cp_para_env_release,& + cp_para_env_retain + USE cp_para_types, ONLY: cp_para_env_type + USE kinds, ONLY: wp=>dp + USE message_passing, ONLY: mp_sum + USE timings, ONLY: timeset,& + timestop + IMPLICIT NONE + PRIVATE - logical, private, parameter :: debug_this_module=.true. - character(len=*), private, parameter :: moduleN='cp_b_matrix_structure' + LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. + CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='cp_b_matrix_structure' - public :: cp_b_distribution_type,cp_b_dims_type,& + PUBLIC :: cp_b_distribution_type,cp_b_dims_type,& cp_b_matrix_struct_type, cp_bs_iterator_type - public :: cp_create, cp_retain, cp_release, cp_get, cp_next,& + PUBLIC :: cp_create, cp_retain, cp_release, cp_get, cp_next,& cp_init, cp_dealloc_ref - public :: cp_freeze_sparsity, cp_get_sparsity_frozen, cp_get_block_info + PUBLIC :: cp_freeze_sparsity, cp_get_sparsity_frozen, cp_get_block_info - public :: cp_dstruct_create, cp_dstruct_retain,& + PUBLIC :: cp_dstruct_create, cp_dstruct_retain,& cp_dstruct_release, cp_dstruct_get, & cp_b_dims_create, cp_b_dims_retain,& cp_b_dims_release,& @@ -63,69 +76,69 @@ module cp_b_matrix_structure cp_bs_iter_init, cp_bs_iter_dealloc_ref, cp_bs_iter_next,& cp_bmstruct_get - interface cp_create - module procedure cp_dstruct_create - end interface - interface cp_dealloc - module procedure cp_dstruct_dealloc - end interface - interface cp_retain - module procedure cp_dstruct_retain - end interface - interface cp_release - module procedure cp_dstruct_release - end interface - interface cp_get - module procedure cp_dstruct_get - end interface + INTERFACE cp_create + MODULE PROCEDURE cp_dstruct_create + END INTERFACE + INTERFACE cp_dealloc + MODULE PROCEDURE cp_dstruct_dealloc + END INTERFACE + INTERFACE cp_retain + MODULE PROCEDURE cp_dstruct_retain + END INTERFACE + INTERFACE cp_release + MODULE PROCEDURE cp_dstruct_release + END INTERFACE + INTERFACE cp_get + MODULE PROCEDURE cp_dstruct_get + END INTERFACE - interface cp_create - module procedure cp_b_dims_create - end interface - interface cp_dealloc - module procedure cp_b_dims_dealloc - end interface - interface cp_retain - module procedure cp_b_dims_retain - end interface - interface cp_release - module procedure cp_b_dims_release - end interface + INTERFACE cp_create + MODULE PROCEDURE cp_b_dims_create + END INTERFACE + INTERFACE cp_dealloc + MODULE PROCEDURE cp_b_dims_dealloc + END INTERFACE + INTERFACE cp_retain + MODULE PROCEDURE cp_b_dims_retain + END INTERFACE + INTERFACE cp_release + MODULE PROCEDURE cp_b_dims_release + END INTERFACE - interface cp_create - module procedure cp_bmstruct_create - end interface - interface cp_dealloc - module procedure cp_bmstruct_dealloc - end interface - interface cp_freeze_sparsity - module procedure cp_bmstruct_freeze_sparsity - end interface - interface cp_get - module procedure cp_bmstruct_get - end interface - interface cp_get_sparsity_frozen - module procedure cp_bmstruct_get_sparsity_frozen - end interface - interface cp_retain - module procedure cp_bmstruct_retain - end interface - interface cp_release - module procedure cp_bmstruct_release - end interface - interface cp_get_block_info - module procedure cp_bmstruct_get_block_info - end interface + INTERFACE cp_create + MODULE PROCEDURE cp_bmstruct_create + END INTERFACE + INTERFACE cp_dealloc + MODULE PROCEDURE cp_bmstruct_dealloc + END INTERFACE + INTERFACE cp_freeze_sparsity + MODULE PROCEDURE cp_bmstruct_freeze_sparsity + END INTERFACE + INTERFACE cp_get + MODULE PROCEDURE cp_bmstruct_get + END INTERFACE + INTERFACE cp_get_sparsity_frozen + MODULE PROCEDURE cp_bmstruct_get_sparsity_frozen + END INTERFACE + INTERFACE cp_retain + MODULE PROCEDURE cp_bmstruct_retain + END INTERFACE + INTERFACE cp_release + MODULE PROCEDURE cp_bmstruct_release + END INTERFACE + INTERFACE cp_get_block_info + MODULE PROCEDURE cp_bmstruct_get_block_info + END INTERFACE - interface cp_init - module procedure cp_bs_iter_init - end interface - interface cp_dealloc_ref - module procedure cp_bs_iter_dealloc_ref - end interface - interface cp_next - module procedure cp_bs_iter_next - end interface + INTERFACE cp_init + MODULE PROCEDURE cp_bs_iter_init + END INTERFACE + INTERFACE cp_dealloc_ref + MODULE PROCEDURE cp_bs_iter_dealloc_ref + END INTERFACE + INTERFACE cp_next + MODULE PROCEDURE cp_bs_iter_next + END INTERFACE !*** !**************************************************************************** @@ -158,12 +171,12 @@ module cp_b_matrix_structure !! !! SOURCE !*************************************************************************** - type cp_b_distribution_type - logical :: initialized - type(cp_para_env_type), pointer :: para_env - integer, dimension(:,:), pointer :: block_owner - integer :: ref_count, id_nr - end type cp_b_distribution_type + TYPE cp_b_distribution_type + LOGICAL :: initialized + TYPE(cp_para_env_type), POINTER :: para_env + INTEGER, DIMENSION(:,:), POINTER :: block_owner + INTEGER :: ref_count, id_nr + END TYPE cp_b_distribution_type !!*** !**************************************************************************** @@ -199,11 +212,11 @@ module cp_b_matrix_structure !! !! SOURCE !*************************************************************************** - type cp_b_dims_type - logical :: initialized - integer, dimension(:), pointer :: block_begins_at_row, block_begins_at_col - integer :: ref_count, id_nr - end type cp_b_dims_type + TYPE cp_b_dims_type + LOGICAL :: initialized + INTEGER, DIMENSION(:), POINTER :: block_begins_at_row, block_begins_at_col + INTEGER :: ref_count, id_nr + END TYPE cp_b_dims_type !!*** !**************************************************************************** @@ -239,13 +252,13 @@ module cp_b_matrix_structure !! !! SOURCE !*************************************************************************** - type cp_b_matrix_struct_type - logical :: initialized, sparsity_frozen, symmetric - type(cp_b_dims_type), pointer :: b_dims - type(cp_b_distribution_type), pointer :: distribution - logical, dimension(:,:), pointer :: sparsity - integer :: ref_count, id_nr - end type cp_b_matrix_struct_type + TYPE cp_b_matrix_struct_type + LOGICAL :: initialized, sparsity_frozen, symmetric + TYPE(cp_b_dims_type), POINTER :: b_dims + TYPE(cp_b_distribution_type), POINTER :: distribution + LOGICAL, DIMENSION(:,:), POINTER :: sparsity + INTEGER :: ref_count, id_nr + END TYPE cp_b_matrix_struct_type !!*** !**************************************************************************** @@ -283,15 +296,15 @@ module cp_b_matrix_structure !! !! SOURCE !*************************************************************************** - type cp_bs_iterator_type - logical :: initialized, do_global, do_zero, do_lower_half - integer :: block_row,block_col,n_block_rows, n_block_cols - type(cp_b_matrix_struct_type), pointer :: m_struct - end type cp_bs_iterator_type + TYPE cp_bs_iterator_type + LOGICAL :: initialized, do_global, do_zero, do_lower_half + INTEGER :: block_row,block_col,n_block_rows, n_block_cols + TYPE(cp_b_matrix_struct_type), POINTER :: m_struct + END TYPE cp_bs_iterator_type !!*** !**************************************************************************** -contains +CONTAINS !======= block distribution structure ======= @@ -331,38 +344,38 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_dstruct_create(d_struct,para_env,n_block_rows,n_block_cols,& + SUBROUTINE cp_dstruct_create(d_struct,para_env,n_block_rows,n_block_cols,& error) - type(cp_b_distribution_type), pointer :: d_struct - type(cp_para_env_type), pointer :: para_env - integer, intent(in) :: n_block_rows, n_block_cols - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_b_distribution_type), POINTER :: d_struct + TYPE(cp_para_env_type), POINTER :: para_env + INTEGER, INTENT(in) :: n_block_rows, n_block_cols + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: stat - integer, save :: last_id_nr=0 - character(len=*), parameter :: routineN='cp_b_distribution_type',& + LOGICAL :: failure + INTEGER :: stat + INTEGER, SAVE :: last_id_nr=0 + CHARACTER(len=*), PARAMETER :: routineN='cp_b_distribution_type',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(n_block_cols>0,cp_failure_level,routineP,error,failure) CPPrecondition(n_block_rows>0,cp_failure_level,routineP,error,failure) - if (.not.failure) then - allocate(d_struct,stat=stat) + IF (.not.failure) THEN + ALLOCATE(d_struct,stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - end if - if (.not. failure) then + END IF + IF (.NOT. failure) THEN last_id_nr=last_id_nr+1 d_struct%para_env => para_env - call cp_para_env_retain(para_env,error=error) - allocate(d_struct%block_owner(n_block_rows,n_block_cols),stat=stat) + CALL cp_para_env_retain(para_env,error=error) + ALLOCATE(d_struct%block_owner(n_block_rows,n_block_cols),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) d_struct%block_owner=para_env%source d_struct%ref_count=1 d_struct%id_nr=last_id_nr - d_struct%initialized=.true. - end if - end subroutine cp_dstruct_create + d_struct%initialized=.TRUE. + END IF + END SUBROUTINE cp_dstruct_create !*************************************************************************** !!****f* cp_b_matrix_structure/cp_dstruct_dealloc [1.0] * @@ -395,32 +408,32 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_dstruct_dealloc(d_struct,error) - type(cp_b_distribution_type), pointer :: d_struct - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_dstruct_dealloc(d_struct,error) + TYPE(cp_b_distribution_type), POINTER :: d_struct + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: stat - character(len=*), parameter :: routineN='cp_dstruct_dealloc',& + LOGICAL :: failure + INTEGER :: stat + CHARACTER(len=*), PARAMETER :: routineN='cp_dstruct_dealloc',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (associated(d_struct)) then + IF (ASSOCIATED(d_struct)) THEN CPPrecondition(d_struct%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then + IF (.NOT. failure) THEN CPPreconditionNoFail(d_struct%ref_count==0,cp_warning_level,routineP,error) d_struct%ref_count=-1 - call cp_para_env_release(d_struct%para_env,error=error) - if (associated(d_struct%block_owner)) then - deallocate(d_struct%block_owner,stat=stat) + CALL cp_para_env_release(d_struct%para_env,error=error) + IF (ASSOCIATED(d_struct%block_owner)) THEN + DEALLOCATE(d_struct%block_owner,stat=stat) CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - end if - d_struct%initialized=.false. - end if - deallocate(d_struct,stat=stat) + END IF + d_struct%initialized=.FALSE. + END IF + DEALLOCATE(d_struct,stat=stat) CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) - end if - end subroutine cp_dstruct_dealloc + END IF + END SUBROUTINE cp_dstruct_dealloc !*************************************************************************** !!****f* cp_b_matrix_structure/cp_dstruct_retain [1.0] * @@ -454,24 +467,24 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_dstruct_retain(d_struct,error) - type(cp_b_distribution_type), pointer :: d_struct - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_dstruct_retain(d_struct,error) + TYPE(cp_b_distribution_type), POINTER :: d_struct + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_dstruct_retain',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_dstruct_retain',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (cp_debug) then - CPPrecondition(associated(d_struct),cp_failure_level,routineP,error,failure) + IF (cp_debug) THEN + CPPrecondition(ASSOCIATED(d_struct),cp_failure_level,routineP,error,failure) CPPrecondition(d_struct%initialized,cp_failure_level,routineP,error,failure) CPPrecondition(d_struct%ref_count>0,cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then + END IF + IF (.not.failure) THEN d_struct%ref_count=d_struct%ref_count+1 - end if - end subroutine cp_dstruct_retain + END IF + END SUBROUTINE cp_dstruct_retain !*************************************************************************** !!****f* cp_b_matrix_structure/cp_dstruct_release [1.0] * @@ -505,29 +518,29 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_dstruct_release(d_struct,error) - type(cp_b_distribution_type), pointer :: d_struct - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_dstruct_release(d_struct,error) + TYPE(cp_b_distribution_type), POINTER :: d_struct + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_dstruct_release',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_dstruct_release',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (associated(d_struct)) then - if (cp_debug) then + IF (ASSOCIATED(d_struct)) THEN + IF (cp_debug) THEN CPPrecondition(d_struct%initialized,cp_failure_level,routineP,error,failure) CPPrecondition(d_struct%ref_count>0,cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then + END IF + IF (.not.failure) THEN d_struct%ref_count=d_struct%ref_count-1 - if (d_struct%ref_count<1) then - call cp_dstruct_dealloc(d_struct) - end if - end if - end if - nullify(d_struct) - end subroutine cp_dstruct_release + IF (d_struct%ref_count<1) THEN + CALL cp_dstruct_dealloc(d_struct) + END IF + END IF + END IF + NULLIFY(d_struct) + END SUBROUTINE cp_dstruct_release !*************************************************************************** !!****f* cp_b_matrix_structure/cp_dstruct_get [1.0] * @@ -564,23 +577,23 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_dstruct_get(d_struct, block_owner, para_env, error) - type(cp_b_distribution_type), intent(in) :: d_struct - integer, dimension(:,:), pointer, optional :: block_owner - type(cp_para_env_type), pointer, optional :: para_env - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_dstruct_get(d_struct, block_owner, para_env, error) + TYPE(cp_b_distribution_type), INTENT(in) :: d_struct + INTEGER, DIMENSION(:,:), POINTER, OPTIONAL :: block_owner + TYPE(cp_para_env_type), POINTER, OPTIONAL :: para_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_dstruct_get',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_dstruct_get',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(d_struct%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (present(block_owner)) block_owner => d_struct%block_owner - if (present(para_env)) para_env = d_struct%para_env - end if - end subroutine cp_dstruct_get + IF (.NOT. failure) THEN + IF (PRESENT(block_owner)) block_owner => d_struct%block_owner + IF (PRESENT(para_env)) para_env = d_struct%para_env + END IF + END SUBROUTINE cp_dstruct_get !*************************************************************************** !====== dimensions structure ====== @@ -610,50 +623,50 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_b_dims_create(b_dims, b_row_sizes, b_col_sizes, error) - type(cp_b_dims_type), pointer :: b_dims - integer, dimension(:), intent(in) :: b_row_sizes, b_col_sizes - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_b_dims_create(b_dims, b_row_sizes, b_col_sizes, error) + TYPE(cp_b_dims_type), POINTER :: b_dims + INTEGER, DIMENSION(:), INTENT(in) :: b_row_sizes, b_col_sizes + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: stat,i - integer, save :: last_id_nr=0 - character(len=*), parameter :: routineN='cp_b_dims_create',& + LOGICAL :: failure + INTEGER :: stat,i + INTEGER, SAVE :: last_id_nr=0 + CHARACTER(len=*), PARAMETER :: routineN='cp_b_dims_create',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - CPPrecondition(size(b_row_sizes)>0,cp_failure_level,routineP,error,failure) - CPPrecondition(size(b_col_sizes)>0,cp_failure_level,routineP,error,failure) - if(cp_debug) then - CPPrecondition(all(b_row_sizes>=0),cp_failure_level,routineP,error,failure) - CPPrecondition(all(b_col_sizes>=0),cp_failure_level,routineP,error,failure) - end if - if (.not. failure) then - allocate (b_dims,stat=stat) + CPPrecondition(SIZE(b_row_sizes)>0,cp_failure_level,routineP,error,failure) + CPPrecondition(SIZE(b_col_sizes)>0,cp_failure_level,routineP,error,failure) + IF(cp_debug) THEN + CPPrecondition(ALL(b_row_sizes>=0),cp_failure_level,routineP,error,failure) + CPPrecondition(ALL(b_col_sizes>=0),cp_failure_level,routineP,error,failure) + END IF + IF (.NOT. failure) THEN + ALLOCATE (b_dims,stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then + END IF + IF (.not.failure) THEN last_id_nr=last_id_nr+1 b_dims%id_nr=last_id_nr b_dims%ref_count=1 - allocate (b_dims%block_begins_at_row(size(b_row_sizes)+1),& - b_dims%block_begins_at_col(size(b_col_sizes)+1),stat=stat) + ALLOCATE (b_dims%block_begins_at_row(SIZE(b_row_sizes)+1),& + b_dims%block_begins_at_col(SIZE(b_col_sizes)+1),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then + END IF + IF (.not.failure) THEN b_dims%block_begins_at_row(1)=1 - do i=1,size(b_row_sizes) + DO i=1,SIZE(b_row_sizes) b_dims%block_begins_at_row(i+1)=b_dims%block_begins_at_row(i)+& b_row_sizes(i) - end do + END DO b_dims%block_begins_at_col(1)=1 - do i=1,size(b_col_sizes) + DO i=1,SIZE(b_col_sizes) b_dims%block_begins_at_col(i+1)=b_dims%block_begins_at_col(i)+& b_col_sizes(i) - end do - b_dims%initialized=.true. - end if - end subroutine cp_b_dims_create + END DO + b_dims%initialized=.TRUE. + END IF + END SUBROUTINE cp_b_dims_create !*************************************************************************** !!****f* cp_matrix_structure/cp_b_dims_dealloc [1.0] * @@ -686,34 +699,34 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_b_dims_dealloc(b_dims,error) - type(cp_b_dims_type), pointer :: b_dims - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_b_dims_dealloc(b_dims,error) + TYPE(cp_b_dims_type), POINTER :: b_dims + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: stat - character(len=*), parameter :: routineN='cp_b_dims_dealloc',& + LOGICAL :: failure + INTEGER :: stat + CHARACTER(len=*), PARAMETER :: routineN='cp_b_dims_dealloc',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(b_dims%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then + IF (.NOT. failure) THEN CPPreconditionNoFail(b_dims%ref_count==0,cp_warning_level,routineP,error) - if (associated(b_dims)) then - if (associated(b_dims%block_begins_at_row)) then - deallocate(b_dims%block_begins_at_row, stat=stat) + IF (ASSOCIATED(b_dims)) THEN + IF (ASSOCIATED(b_dims%block_begins_at_row)) THEN + DEALLOCATE(b_dims%block_begins_at_row, stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - if (associated(b_dims%block_begins_at_col)) then - deallocate(b_dims%block_begins_at_col,stat=stat) + END IF + IF (ASSOCIATED(b_dims%block_begins_at_col)) THEN + DEALLOCATE(b_dims%block_begins_at_col,stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - b_dims%initialized=.false. - deallocate(b_dims,stat=stat) + END IF + b_dims%initialized=.FALSE. + DEALLOCATE(b_dims,stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - end if - end subroutine cp_b_dims_dealloc + END IF + END IF + END SUBROUTINE cp_b_dims_dealloc !*************************************************************************** !!****f* cp_matrix_structure/cp_b_dims_retain [1.0] * @@ -747,21 +760,21 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_b_dims_retain(b_dims,error) - type(cp_b_dims_type), intent(inout) :: b_dims - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_b_dims_retain(b_dims,error) + TYPE(cp_b_dims_type), INTENT(inout) :: b_dims + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_b_dims_retain',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_b_dims_retain',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(b_dims%initialized,cp_failure_level,routineP,error,failure) CPPreconditionNoFail(b_dims%ref_count>0,cp_warning_level,routineP,error) - if (.not. failure) then + IF (.NOT. failure) THEN b_dims%ref_count=b_dims%ref_count+1 - end if - end subroutine cp_b_dims_retain + END IF + END SUBROUTINE cp_b_dims_retain !*************************************************************************** !!****f* cp_matrix_structure/cp_b_dims_release [1.0] * @@ -795,29 +808,29 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_b_dims_release(b_dims,error) - type(cp_b_dims_type), pointer :: b_dims - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_b_dims_release(b_dims,error) + TYPE(cp_b_dims_type), POINTER :: b_dims + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_b_dims_release',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_b_dims_release',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (associated(b_dims)) then - if (cp_debug) then + IF (ASSOCIATED(b_dims)) THEN + IF (cp_debug) THEN CPPrecondition(b_dims%initialized,cp_failure_level,routineP,error,failure) CPPrecondition(b_dims%ref_count>0,cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then + END IF + IF (.not.failure) THEN b_dims%ref_count=b_dims%ref_count-1 - if (b_dims%ref_count<1) then - call cp_b_dims_dealloc(b_dims,error) - end if - end if - end if - nullify(b_dims) - end subroutine cp_b_dims_release + IF (b_dims%ref_count<1) THEN + CALL cp_b_dims_dealloc(b_dims,error) + END IF + END IF + END IF + NULLIFY(b_dims) + END SUBROUTINE cp_b_dims_release !*************************************************************************** !======== matrix structure ======== @@ -870,101 +883,101 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_bmstruct_create(m_struct,symmetric,d_struct,b_dims, & + SUBROUTINE cp_bmstruct_create(m_struct,symmetric,d_struct,b_dims, & sparsity, no_sparsity, para_env, b_row_sizes, b_col_sizes,error) - type(cp_b_matrix_struct_type), pointer :: m_struct - type(cp_b_distribution_type), target, intent(inout), optional :: d_struct - type(cp_b_dims_type), target, intent(inout), optional :: b_dims - logical, dimension(:,:), optional :: sparsity !, intent(in) - logical, intent(in), optional :: no_sparsity, symmetric - type(cp_para_env_type), pointer, optional :: para_env - integer, dimension(:), intent(in), optional :: b_row_sizes, b_col_sizes - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_b_matrix_struct_type), POINTER :: m_struct + TYPE(cp_b_distribution_type), TARGET, INTENT(inout), OPTIONAL :: d_struct + TYPE(cp_b_dims_type), TARGET, INTENT(inout), OPTIONAL :: b_dims + LOGICAL, DIMENSION(:,:), OPTIONAL :: sparsity !, intent(in) + LOGICAL, INTENT(in), OPTIONAL :: no_sparsity, symmetric + TYPE(cp_para_env_type), POINTER, OPTIONAL :: para_env + INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: b_row_sizes, b_col_sizes + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure, no_spars - integer :: stat - integer, save :: last_id_nr=0 - character(len=*), parameter :: routineN='cp_bmstruct_create',& + LOGICAL :: failure, no_spars + INTEGER :: stat + INTEGER, SAVE :: last_id_nr=0 + CHARACTER(len=*), PARAMETER :: routineN='cp_bmstruct_create',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - no_spars=.false. - if (present(no_sparsity)) no_spars=no_sparsity - allocate(m_struct, stat=stat) + no_spars=.FALSE. + IF (PRESENT(no_sparsity)) no_spars=no_sparsity + ALLOCATE(m_struct, stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (.not. failure) then + IF (.NOT. failure) THEN last_id_nr=last_id_nr+1 m_struct%id_nr=last_id_nr - m_struct%sparsity_frozen= present(sparsity).or.no_spars - m_struct%symmetric=.true. ! make it default to false - if (present(symmetric)) m_struct%symmetric=symmetric + m_struct%sparsity_frozen= PRESENT(sparsity).or.no_spars + m_struct%symmetric=.TRUE. ! make it default to false + IF (PRESENT(symmetric)) m_struct%symmetric=symmetric m_struct%ref_count=1 - if (present(d_struct)) then + IF (PRESENT(d_struct)) THEN m_struct%distribution => d_struct - call cp_retain(m_struct%distribution, error=error) - else - CPPrecondition(present(para_env),cp_failure_level,routineP,error,failure) - if (.not.present(b_dims)) then - CPPrecondition(present(b_col_sizes),cp_failure_level,routineP,error,failure) - CPPrecondition(present(b_row_sizes),cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_dstruct_create(m_struct%distribution,para_env=para_env,& - n_block_rows=size(b_row_sizes),& - n_block_cols=size(b_col_sizes),& + CALL cp_retain(m_struct%distribution, error=error) + ELSE + CPPrecondition(PRESENT(para_env),cp_failure_level,routineP,error,failure) + IF (.not.PRESENT(b_dims)) THEN + CPPrecondition(PRESENT(b_col_sizes),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(b_row_sizes),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN + CALL cp_dstruct_create(m_struct%distribution,para_env=para_env,& + n_block_rows=SIZE(b_row_sizes),& + n_block_cols=SIZE(b_col_sizes),& error=error) - end if - else - call cp_dstruct_create(m_struct%distribution,para_env=para_env,& - n_block_rows=size(b_dims%block_begins_at_row)-1,& - n_block_cols=size(b_dims%block_begins_at_col)-1,& + END IF + ELSE + CALL cp_dstruct_create(m_struct%distribution,para_env=para_env,& + n_block_rows=SIZE(b_dims%block_begins_at_row)-1,& + n_block_cols=SIZE(b_dims%block_begins_at_col)-1,& error=error) - end if - end if + END IF + END IF - if (present(b_dims)) then + IF (PRESENT(b_dims)) THEN m_struct%b_dims => b_dims - call cp_retain(b_dims,error) - else - CPPrecondition(present(b_col_sizes),cp_failure_level,routineP,error,failure) - CPPrecondition(present(b_row_sizes),cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_b_dims_create(m_struct%b_dims,& + CALL cp_retain(b_dims,error) + ELSE + CPPrecondition(PRESENT(b_col_sizes),cp_failure_level,routineP,error,failure) + CPPrecondition(PRESENT(b_row_sizes),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN + CALL cp_b_dims_create(m_struct%b_dims,& b_row_sizes=b_row_sizes,& b_col_sizes=b_col_sizes,& error=error) - end if - end if - end if - if (.not.failure) then - if (no_spars) then - if (present(sparsity)) then + END IF + END IF + END IF + IF (.not.failure) THEN + IF (no_spars) THEN + IF (PRESENT(sparsity)) THEN !CPPreconditionNoFail(.not.associated(sparsity),cp_warning_level,routineP,error) - end if - nullify(m_struct%sparsity) - else if (present(sparsity)) then + END IF + NULLIFY(m_struct%sparsity) + ELSE IF (PRESENT(sparsity)) THEN !if (associated(sparsity)) then - allocate(m_struct%sparsity(& - size(m_struct%b_dims%block_begins_at_row)-1,& - size(m_struct%b_dims%block_begins_at_col)-1),stat=stat) + ALLOCATE(m_struct%sparsity(& + SIZE(m_struct%b_dims%block_begins_at_row)-1,& + SIZE(m_struct%b_dims%block_begins_at_col)-1),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - CPPostcondition(size(m_struct%sparsity,1)==size(sparsity,1),cp_failure_level,routineP,error,failure) - CPPostcondition(size(m_struct%sparsity,2)==size(sparsity,2),cp_failure_level,routineP,error,failure) - if (.not.failure) m_struct%sparsity=sparsity + CPPostcondition(SIZE(m_struct%sparsity,1)==SIZE(sparsity,1),cp_failure_level,routineP,error,failure) + CPPostcondition(SIZE(m_struct%sparsity,2)==SIZE(sparsity,2),cp_failure_level,routineP,error,failure) + IF (.not.failure) m_struct%sparsity=sparsity !end if - else - allocate(m_struct%sparsity(& - size(m_struct%b_dims%block_begins_at_row)-1,& - size(m_struct%b_dims%block_begins_at_col)-1),stat=stat) + ELSE + ALLOCATE(m_struct%sparsity(& + SIZE(m_struct%b_dims%block_begins_at_row)-1,& + SIZE(m_struct%b_dims%block_begins_at_col)-1),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (.not.failure) then - m_struct%sparsity=.false. - end if - end if - end if + IF (.not.failure) THEN + m_struct%sparsity=.FALSE. + END IF + END IF + END IF m_struct%initialized=.not.failure CPPostcondition(m_struct%initialized,cp_failure_level,routineP,error,failure) - end subroutine cp_bmstruct_create + END SUBROUTINE cp_bmstruct_create !*************************************************************************** !!****f* cp_b_matrix_structure/cp_bmstruct_dealloc [1.0] * @@ -998,34 +1011,34 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_bmstruct_dealloc(m_struct,error) - type(cp_b_matrix_struct_type), pointer :: m_struct - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_bmstruct_dealloc(m_struct,error) + TYPE(cp_b_matrix_struct_type), POINTER :: m_struct + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: stat - character(len=*), parameter :: routineN='cp_bmstruct_dealloc',& + LOGICAL :: failure + INTEGER :: stat + CHARACTER(len=*), PARAMETER :: routineN='cp_bmstruct_dealloc',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (associated(m_struct)) then + IF (ASSOCIATED(m_struct)) THEN CPPrecondition(m_struct%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then + IF (.not.failure) THEN CPPreconditionNoFail(m_struct%ref_count==0,cp_warning_level,routineP,error) - m_struct%initialized=.false. - if (associated(m_struct%b_dims)) then - call cp_release(m_struct%b_dims, error) - end if - if (associated(m_struct%distribution)) then - call cp_release(m_struct%distribution,error) - end if - if (associated(m_struct%sparsity)) then - deallocate(m_struct%sparsity, stat=stat) + m_struct%initialized=.FALSE. + IF (ASSOCIATED(m_struct%b_dims)) THEN + CALL cp_release(m_struct%b_dims, error) + END IF + IF (ASSOCIATED(m_struct%distribution)) THEN + CALL cp_release(m_struct%distribution,error) + END IF + IF (ASSOCIATED(m_struct%sparsity)) THEN + DEALLOCATE(m_struct%sparsity, stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - end if - end if - end subroutine cp_bmstruct_dealloc + END IF + END IF + END IF + END SUBROUTINE cp_bmstruct_dealloc !*************************************************************************** !!****f* cp_b_matrix_structure/cp_bmstruct_get [1.0] * @@ -1064,35 +1077,35 @@ contains !! 4.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_bmstruct_get(m_struct, para_env, sparsity, sparsity_frozen,& +SUBROUTINE cp_bmstruct_get(m_struct, para_env, sparsity, sparsity_frozen,& symmetric,& b_dims, distribution, id_nr, ref_count, error) - type(cp_b_matrix_struct_type), intent(in) :: m_struct - type(cp_para_env_type), pointer, optional :: para_env - type(cp_b_dims_type), pointer, optional :: b_dims - type(cp_b_distribution_type), pointer, optional :: distribution - logical, dimension(:,:), pointer, optional :: sparsity - integer, intent(out), optional:: ref_count, id_nr - logical, intent(out), optional:: sparsity_frozen, symmetric - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_b_matrix_struct_type), INTENT(in) :: m_struct + TYPE(cp_para_env_type), POINTER, OPTIONAL :: para_env + TYPE(cp_b_dims_type), POINTER, OPTIONAL :: b_dims + TYPE(cp_b_distribution_type), POINTER, OPTIONAL :: distribution + LOGICAL, DIMENSION(:,:), POINTER, OPTIONAL :: sparsity + INTEGER, INTENT(out), OPTIONAL:: ref_count, id_nr + LOGICAL, INTENT(out), OPTIONAL:: sparsity_frozen, symmetric + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_bmstruct_get',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_bmstruct_get',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(m_struct%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (present(sparsity)) sparsity => m_struct%sparsity - if (present(sparsity_frozen)) & + IF (.NOT. failure) THEN + IF (PRESENT(sparsity)) sparsity => m_struct%sparsity + IF (PRESENT(sparsity_frozen)) & sparsity_frozen = cp_bmstruct_get_sparsity_frozen(m_struct,error) - if (present(symmetric)) symmetric=m_struct%symmetric - if (present(b_dims)) b_dims => m_struct%b_dims - if (present(distribution)) distribution => m_struct%distribution - if (present(ref_count)) ref_count=m_struct%ref_count - if (present(id_nr)) id_nr=m_struct%id_nr - end if -end subroutine cp_bmstruct_get + IF (PRESENT(symmetric)) symmetric=m_struct%symmetric + IF (PRESENT(b_dims)) b_dims => m_struct%b_dims + IF (PRESENT(distribution)) distribution => m_struct%distribution + IF (PRESENT(ref_count)) ref_count=m_struct%ref_count + IF (PRESENT(id_nr)) id_nr=m_struct%id_nr + END IF +END SUBROUTINE cp_bmstruct_get !*************************************************************************** !!****f* cp_b_matrix_structureure/cp_bmstruct_freeze_sparsity [1.0] * @@ -1130,49 +1143,49 @@ end subroutine cp_bmstruct_get !! none !! !!*** ********************************************************************** - subroutine cp_bmstruct_freeze_sparsity(matrix_struct,no_sync,error) - type(cp_b_matrix_struct_type), intent(inout) :: matrix_struct - logical, optional, intent(in) :: no_sync - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_bmstruct_freeze_sparsity(matrix_struct,no_sync,error) + TYPE(cp_b_matrix_struct_type), INTENT(inout) :: matrix_struct + LOGICAL, OPTIONAL, INTENT(in) :: no_sync + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure, sync - integer :: handle, stat - integer, allocatable, dimension(:,:) :: tmp_distr - character(len=*), parameter :: routineN='cp_bmstruct_freeze_sparsity',& + LOGICAL :: failure, sync + INTEGER :: handle, stat + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: tmp_distr + CHARACTER(len=*), PARAMETER :: routineN='cp_bmstruct_freeze_sparsity',& routineP=moduleN//':'//routineN - failure=.false. - sync=.true. + failure=.FALSE. + sync=.TRUE. - call timeset(routineN//','//moduleN,'I',"",handle) + CALL timeset(routineN//','//moduleN,'I',"",handle) CPPrecondition(matrix_struct%initialized,cp_failure_level,routineP,error,failure) - if ((.not. failure) .and. (.not. matrix_struct%sparsity_frozen)) then - if (present(no_sync)) sync=.not.no_sync - if (sync) then - where (matrix_struct%distribution%block_owner /= & - matrix_struct%distribution%para_env%mepos) matrix_struct%sparsity = .false. + IF ((.NOT. failure) .AND. (.NOT. matrix_struct%sparsity_frozen)) THEN + IF (PRESENT(no_sync)) sync=.not.no_sync + IF (sync) THEN + WHERE (matrix_struct%distribution%block_owner /= & + matrix_struct%distribution%para_env%mepos) matrix_struct%sparsity = .FALSE. ! would be nice to do this directly with logical (or at least use ! the bits of the integer - allocate (tmp_distr(size(matrix_struct%sparsity,1),& - size(matrix_struct%sparsity,2)), stat=stat) + ALLOCATE (tmp_distr(SIZE(matrix_struct%sparsity,1),& + SIZE(matrix_struct%sparsity,2)), stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - where (matrix_struct%sparsity) + WHERE (matrix_struct%sparsity) tmp_distr = 0 - elsewhere + ELSEWHERE tmp_distr = 1 - end where - call mp_sum(tmp_distr,matrix_struct%distribution%para_env%group) - where (tmp_distr == 0) - matrix_struct%sparsity = .false. - elsewhere - matrix_struct%sparsity = .true. - end where - deallocate(tmp_distr,stat=stat) + END WHERE + CALL mp_sum(tmp_distr,matrix_struct%distribution%para_env%group) + WHERE (tmp_distr == 0) + matrix_struct%sparsity = .FALSE. + ELSEWHERE + matrix_struct%sparsity = .TRUE. + END WHERE + DEALLOCATE(tmp_distr,stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - matrix_struct%sparsity_frozen=.true. - end if - call timestop(0.0_wp,handle) - end subroutine cp_bmstruct_freeze_sparsity + END IF + matrix_struct%sparsity_frozen=.TRUE. + END IF + CALL timestop(0.0_wp,handle) + END SUBROUTINE cp_bmstruct_freeze_sparsity !*************************************************************************** !!****f* cp_b_matrix_structure/cp_bmstruct_get_sparsity_frozen [1.0] * @@ -1207,26 +1220,26 @@ end subroutine cp_bmstruct_get !! none !! !!*** ********************************************************************** - function cp_bmstruct_get_sparsity_frozen(matrix_struct,error) result(res) - type(cp_b_matrix_struct_type), intent(in) :: matrix_struct - type(cp_error_type), optional, intent(inout) :: error - logical :: res + FUNCTION cp_bmstruct_get_sparsity_frozen(matrix_struct,error) RESULT(res) + TYPE(cp_b_matrix_struct_type), INTENT(in) :: matrix_struct + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error + LOGICAL :: res - logical :: failure - integer :: handle - character(len=*), parameter :: routineN='cp_bmstruct_get_sparsity_frozen',& + LOGICAL :: failure + INTEGER :: handle + CHARACTER(len=*), PARAMETER :: routineN='cp_bmstruct_get_sparsity_frozen',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - call timeset(routineN//','//moduleN,'I',"",handle) + CALL timeset(routineN//','//moduleN,'I',"",handle) CPPrecondition(matrix_struct%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - CPPrecondition(.false.,cp_warning_level,routineP,error,failure) + IF (.NOT. failure) THEN + CPPrecondition(.FALSE.,cp_warning_level,routineP,error,failure) ! to do - end if - res=.false. - call timestop(0.0_wp,handle) - end function cp_bmstruct_get_sparsity_frozen + END IF + res=.FALSE. + CALL timestop(0.0_wp,handle) + END FUNCTION cp_bmstruct_get_sparsity_frozen !*************************************************************************** !!****f* cp_matrix_structure/cp_bmstruct_retain [1.0] * @@ -1260,21 +1273,21 @@ end subroutine cp_bmstruct_get !! none !! !!*** ********************************************************************** - subroutine cp_bmstruct_retain(m_struct,error) - type(cp_b_matrix_struct_type), intent(inout) :: m_struct - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_bmstruct_retain(m_struct,error) + TYPE(cp_b_matrix_struct_type), INTENT(inout) :: m_struct + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_bmstruct_retain',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_bmstruct_retain',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(m_struct%initialized,cp_failure_level,routineP,error,failure) CPPreconditionNoFail(m_struct%ref_count>0,cp_warning_level,routineP,error) - if (.not. failure) then + IF (.NOT. failure) THEN m_struct%ref_count=m_struct%ref_count+1 - end if - end subroutine cp_bmstruct_retain + END IF + END SUBROUTINE cp_bmstruct_retain !*************************************************************************** !!****f* cp_matrix_structure/cp_bmstruct_release [1.0] * @@ -1308,29 +1321,29 @@ end subroutine cp_bmstruct_get !! none !! !!*** ********************************************************************** - subroutine cp_bmstruct_release(m_struct,error) - type(cp_b_matrix_struct_type), pointer :: m_struct - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_bmstruct_release(m_struct,error) + TYPE(cp_b_matrix_struct_type), POINTER :: m_struct + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_bmstruct_release',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_bmstruct_release',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (associated(m_struct)) then - if (cp_debug) then + IF (ASSOCIATED(m_struct)) THEN + IF (cp_debug) THEN CPPrecondition(m_struct%initialized,cp_failure_level,routineP,error,failure) CPPrecondition(m_struct%ref_count>0,cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then + END IF + IF (.not.failure) THEN m_struct%ref_count=m_struct%ref_count-1 - if (m_struct%ref_count<1) then - call cp_dealloc(m_struct,error) - end if - end if - end if - nullify(m_struct) - end subroutine cp_bmstruct_release + IF (m_struct%ref_count<1) THEN + CALL cp_dealloc(m_struct,error) + END IF + END IF + END IF + NULLIFY(m_struct) + END SUBROUTINE cp_bmstruct_release !*************************************************************************** !!****f* cp_b_matrix_structure/cp_bmstruct_get_block_info [1.0] * @@ -1381,58 +1394,58 @@ end subroutine cp_bmstruct_get !! none !! !!*** ********************************************************************** - subroutine cp_bmstruct_get_block_info(m_struct,block_row, block_col,& + SUBROUTINE cp_bmstruct_get_block_info(m_struct,block_row, block_col,& owner,n_local_rows,n_local_cols,begins_at_row,ends_at_row,& begins_at_col,ends_at_col,out_of_sparsity, me_owner, error) - type(cp_b_matrix_struct_type), intent(in) :: m_struct - integer, intent(in) :: block_col, block_row - integer, intent(out), optional :: owner, n_local_rows,n_local_cols,& + TYPE(cp_b_matrix_struct_type), INTENT(in) :: m_struct + INTEGER, INTENT(in) :: block_col, block_row + INTEGER, INTENT(out), OPTIONAL :: owner, n_local_rows,n_local_cols,& begins_at_row,begins_at_col, ends_at_row, ends_at_col - logical, intent(out), optional :: me_owner, out_of_sparsity - type(cp_error_type), optional, intent(inout) :: error + LOGICAL, INTENT(out), OPTIONAL :: me_owner, out_of_sparsity + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_bmstruct_get_block_info',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_bmstruct_get_block_info',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(m_struct%initialized,cp_failure_level,routineP,error,failure) - if (cp_debug) then + IF (cp_debug) THEN CPPrecondition(block_row>0,cp_failure_level,routineP,error,failure) CPPrecondition(block_col>0,cp_failure_level,routineP,error,failure) ! check also the upper bound? - CPPrecondition(associated(m_struct%b_dims),cp_failure_level,routineP,error,failure) - CPPrecondition(associated(m_struct%distribution),cp_failure_level,routineP,error,failure) - if (.not.failure) then - CPPrecondition(associated(m_struct%b_dims%block_begins_at_col),cp_failure_level,routineP,error,failure) - CPPrecondition(associated(m_struct%b_dims%block_begins_at_row),cp_failure_level,routineP,error,failure) - CPPrecondition(associated(m_struct%distribution%block_owner),cp_failure_level,routineP,error,failure) - end if - end if - if (.not. failure) then - if (present(owner)) owner=m_struct%distribution%block_owner(block_row,block_col) - if (present(n_local_rows)) then + CPPrecondition(ASSOCIATED(m_struct%b_dims),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_struct%distribution),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN + CPPrecondition(ASSOCIATED(m_struct%b_dims%block_begins_at_col),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_struct%b_dims%block_begins_at_row),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(m_struct%distribution%block_owner),cp_failure_level,routineP,error,failure) + END IF + END IF + IF (.NOT. failure) THEN + IF (PRESENT(owner)) owner=m_struct%distribution%block_owner(block_row,block_col) + IF (PRESENT(n_local_rows)) THEN n_local_rows=m_struct%b_dims%block_begins_at_row(block_row+1)-& m_struct%b_dims%block_begins_at_row(block_row) - end if - if (present(n_local_cols)) then + END IF + IF (PRESENT(n_local_cols)) THEN n_local_cols=m_struct%b_dims%block_begins_at_col(block_col+1)-& m_struct%b_dims%block_begins_at_col(block_col) - end if - if (present(begins_at_row)) begins_at_row=m_struct%b_dims%block_begins_at_row(block_row) - if (present(begins_at_col)) begins_at_col=m_struct%b_dims%block_begins_at_col(block_col) - if (present(ends_at_row)) ends_at_row=m_struct%b_dims%block_begins_at_row(block_row+1)-1 - if (present(ends_at_col)) ends_at_col=m_struct%b_dims%block_begins_at_col(block_col+1)-1 - if (present(out_of_sparsity)) then - if (.not.m_struct%sparsity_frozen .or. & - .not.associated(m_struct%sparsity)) then - out_of_sparsity=.false. - else + END IF + IF (PRESENT(begins_at_row)) begins_at_row=m_struct%b_dims%block_begins_at_row(block_row) + IF (PRESENT(begins_at_col)) begins_at_col=m_struct%b_dims%block_begins_at_col(block_col) + IF (PRESENT(ends_at_row)) ends_at_row=m_struct%b_dims%block_begins_at_row(block_row+1)-1 + IF (PRESENT(ends_at_col)) ends_at_col=m_struct%b_dims%block_begins_at_col(block_col+1)-1 + IF (PRESENT(out_of_sparsity)) THEN + IF (.not.m_struct%sparsity_frozen .OR. & + .not.ASSOCIATED(m_struct%sparsity)) THEN + out_of_sparsity=.FALSE. + ELSE out_of_sparsity=m_struct%sparsity(block_row,block_col) - end if - end if - end if - end subroutine cp_bmstruct_get_block_info + END IF + END IF + END IF + END SUBROUTINE cp_bmstruct_get_block_info !*************************************************************************** !====== block iterator ====== @@ -1480,34 +1493,34 @@ end subroutine cp_bmstruct_get !! none !! !!*** ********************************************************************** - subroutine cp_bs_iter_init(bs_iterator, m_struct, do_global,& + SUBROUTINE cp_bs_iter_init(bs_iterator, m_struct, do_global,& do_zero, do_lower_half, error) - type(cp_bs_iterator_type), intent(out) :: bs_iterator - type(cp_b_matrix_struct_type), intent(in), target :: m_struct - logical, intent(in) :: do_global - logical, intent(in), optional :: do_zero, do_lower_half - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_bs_iterator_type), INTENT(out) :: bs_iterator + TYPE(cp_b_matrix_struct_type), INTENT(in), TARGET :: m_struct + LOGICAL, INTENT(in) :: do_global + LOGICAL, INTENT(in), OPTIONAL :: do_zero, do_lower_half + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_bs_iter_init',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_bs_iter_init',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(m_struct%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then + IF (.NOT. failure) THEN bs_iterator%do_global=do_global - bs_iterator%do_zero=.false. + bs_iterator%do_zero=.FALSE. bs_iterator%do_lower_half=.not.m_struct%symmetric - if (present(do_zero)) bs_iterator%do_zero=do_zero - if (present(do_lower_half)) bs_iterator%do_lower_half=do_lower_half + IF (PRESENT(do_zero)) bs_iterator%do_zero=do_zero + IF (PRESENT(do_lower_half)) bs_iterator%do_lower_half=do_lower_half bs_iterator%block_row=1 bs_iterator%block_col=1 bs_iterator%m_struct => m_struct - bs_iterator%n_block_rows=size(m_struct%b_dims%block_begins_at_row) - bs_iterator%n_block_cols=size(m_struct%b_dims%block_begins_at_col) - bs_iterator%initialized=.true. - end if - end subroutine cp_bs_iter_init + bs_iterator%n_block_rows=SIZE(m_struct%b_dims%block_begins_at_row) + bs_iterator%n_block_cols=SIZE(m_struct%b_dims%block_begins_at_col) + bs_iterator%initialized=.TRUE. + END IF + END SUBROUTINE cp_bs_iter_init !*************************************************************************** !!****f* cp_b_matrix_structure/cp_bs_iter_dealloc_ref [1.0] * @@ -1540,21 +1553,21 @@ end subroutine cp_bmstruct_get !! none !! !!*** ********************************************************************** - subroutine cp_bs_iter_dealloc_ref(bs_iterator,error) - type(cp_bs_iterator_type), intent(inout) :: bs_iterator - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_bs_iter_dealloc_ref(bs_iterator,error) + TYPE(cp_bs_iterator_type), INTENT(inout) :: bs_iterator + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_bs_iter_dealloc_ref',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_bs_iter_dealloc_ref',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(bs_iterator%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - nullify(bs_iterator%m_struct) - bs_iterator%initialized=.false. - end if - end subroutine cp_bs_iter_dealloc_ref + IF (.NOT. failure) THEN + NULLIFY(bs_iterator%m_struct) + bs_iterator%initialized=.FALSE. + END IF + END SUBROUTINE cp_bs_iter_dealloc_ref !*************************************************************************** !!****f* cp_b_matrix_structure/cp_bs_iter_next [1.0] * @@ -1606,52 +1619,52 @@ end subroutine cp_bmstruct_get !! none !! !!*** ********************************************************************** - function cp_bs_iter_next(bs_iterator,block_row, block_col,& + FUNCTION cp_bs_iter_next(bs_iterator,block_row, block_col,& owner,n_local_rows,n_local_cols,begins_at_row,ends_at_row,& begins_at_col,ends_at_col,out_of_sparsity, me_owner, error)& - result(res) - type(cp_bs_iterator_type), intent(inout) :: bs_iterator - integer, intent(out), optional :: block_col, block_row,owner,& + RESULT(res) + TYPE(cp_bs_iterator_type), INTENT(inout) :: bs_iterator + INTEGER, INTENT(out), OPTIONAL :: block_col, block_row,owner,& n_local_rows,n_local_cols,begins_at_row,begins_at_col,& ends_at_row, ends_at_col - logical, intent(out), optional :: me_owner, out_of_sparsity - type(cp_error_type), optional, intent(inout) :: error - logical :: res + LOGICAL, INTENT(out), OPTIONAL :: me_owner, out_of_sparsity + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error + LOGICAL :: res - logical :: failure - character(len=*), parameter :: routineN='cp_bs_iter_next',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_bs_iter_next',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (cp_debug) then + IF (cp_debug) THEN CPPrecondition(bs_iterator%initialized,cp_failure_level,routineP,error,failure) - end if - if (.not. failure) then + END IF + IF (.NOT. failure) THEN bs_iterator%block_col=bs_iterator%block_col+1 - if (bs_iterator%block_col> bs_iterator%n_block_cols) then + IF (bs_iterator%block_col> bs_iterator%n_block_cols) THEN bs_iterator%block_row=bs_iterator%block_row+1 - if (bs_iterator%block_row<1.or.bs_iterator%block_row> bs_iterator%n_block_rows) then + IF (bs_iterator%block_row<1.or.bs_iterator%block_row> bs_iterator%n_block_rows) THEN bs_iterator%block_row=-1 bs_iterator%block_col= bs_iterator%n_block_cols+1 - if (present(block_row)) block_row=-1 - if (present(block_col)) block_col=-1 - res=.false. - else - if (bs_iterator%do_lower_half) then + IF (PRESENT(block_row)) block_row=-1 + IF (PRESENT(block_col)) block_col=-1 + res=.FALSE. + ELSE + IF (bs_iterator%do_lower_half) THEN bs_iterator%block_col=1 - else + ELSE bs_iterator%block_col=bs_iterator%block_row - end if - end if - end if - if (present(block_row)) block_row=bs_iterator%block_row - if (present(block_col)) block_col=bs_iterator%block_col - call cp_bmstruct_get_block_info(bs_iterator%m_struct,& + END IF + END IF + END IF + IF (PRESENT(block_row)) block_row=bs_iterator%block_row + IF (PRESENT(block_col)) block_col=bs_iterator%block_col + CALL cp_bmstruct_get_block_info(bs_iterator%m_struct,& bs_iterator%block_row, bs_iterator%block_col,& owner,n_local_rows,n_local_cols,begins_at_row,ends_at_row,& begins_at_col,ends_at_col,out_of_sparsity, me_owner, error) - end if - end function cp_bs_iter_next + END IF + END FUNCTION cp_bs_iter_next !*************************************************************************** -end module cp_b_matrix_structure +END MODULE cp_b_matrix_structure diff --git a/src/cp_blacs_env.F b/src/cp_blacs_env.F index ef76f342cc..b14631b72d 100644 --- a/src/cp_blacs_env.F +++ b/src/cp_blacs_env.F @@ -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="(' :{ 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) ' :*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 diff --git a/src/cp_block_matrix.F b/src/cp_block_matrix.F index c9851b0a86..97a82b9e77 100644 --- a/src/cp_block_matrix.F +++ b/src/cp_block_matrix.F @@ -25,87 +25,105 @@ !! !! SOURCE !**************************************************************************** -module cp_block_matrix - 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, cp_precondition_failed - use kinds, only: wp=>dp - use global_types, only: global_environment_type - use string_utilities, only: uppercase - use timings, only: timeset, timestop - use cp_b_matrix_structure - use sparse_matrix_types - use message_passing, only: mp_sync - use cp_matrix_utils, only: cp_sm_alloc_nonsparse_blocks, & - cp_matrix_block_iterator, cp_sm_b_i_init, cp_sm_b_i_next, & - cp_sm_b_i_dealloc_ref, cp_sm_set_to - use qs_blacs, only:cp_sm_fm_multiply, cp_full_matrix_type, cp_fm_get_info - use cp_para_types, only: cp_para_env_type - implicit none - private +MODULE cp_block_matrix + USE cp_b_matrix_structure + 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_precondition_failed,& + 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_matrix_block_iterator,& + cp_sm_alloc_nonsparse_blocks,& + cp_sm_b_i_dealloc_ref,& + cp_sm_b_i_init,& + cp_sm_b_i_next,& + cp_sm_set_to + USE cp_para_types, ONLY: cp_para_env_type + USE global_types, ONLY: global_environment_type + USE kinds, ONLY: wp=>dp + USE message_passing, ONLY: mp_sync + USE qs_blacs, ONLY: cp_fm_get_info,& + cp_full_matrix_type,& + cp_sm_fm_multiply + USE sparse_matrix_types + USE string_utilities, ONLY: uppercase + USE timings, ONLY: timeset,& + timestop + IMPLICIT NONE + PRIVATE - logical, private, parameter :: debug_this_module=.true. - character(len=*), private, parameter :: moduleN='cp_block_matrix' + LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. + CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='cp_block_matrix' - public :: cp_block_matrix_type, cp_sp_block_handle_type,& + PUBLIC :: cp_block_matrix_type, cp_sp_block_handle_type,& cp_block_matrix_p_type - public :: cp_create, cp_dealloc, cp_retain, cp_release, & + PUBLIC :: cp_create, cp_dealloc, cp_retain, cp_release, & cp_get_local_block,& cp_release_block, cp_set_local_block, cp_remove_block,& cp_get_matrix, cp_set_to, cp_get - public :: cp_sp_create, cp_sp_retain, cp_sp_release,& + PUBLIC :: cp_sp_create, cp_sp_retain, cp_sp_release,& cp_sp_get_local_block,& cp_sp_block_handle_release, cp_sp_set_local_block, cp_sp_remove_block,& cp_sp_array_dealloc, cp_sp_get_matrix, cp_sp_array_release,& cp_sp_alloc_nonsparse_blocks, cp_sp_set_to, cp_sp_block_handle_init,& cp_sp_get, cp_sp_multiplies_blacs, cp_sp_array_create - interface cp_init - module procedure cp_sp_block_handle_init - end interface - interface cp_create - module procedure cp_sp_create, cp_sp_array_create - end interface + INTERFACE cp_init + MODULE PROCEDURE cp_sp_block_handle_init + END INTERFACE + INTERFACE cp_create + MODULE PROCEDURE cp_sp_create, cp_sp_array_create + END INTERFACE !FM interface cp_dealloc !FM module procedure cp_sp_dealloc !FM end interface - interface cp_retain - module procedure cp_sp_retain - end interface - interface cp_release - module procedure cp_sp_release, cp_sp_array_release - end interface - interface cp_get_matrix - module procedure cp_sp_get_matrix - end interface - interface cp_flush_cache - module procedure cp_sp_flush_cache - end interface - interface cp_get_local_block - module procedure cp_sp_get_local_block - end interface - interface cp_release_block - module procedure cp_sp_block_handle_release - end interface - interface cp_set_local_block - module procedure cp_sp_set_local_block - end interface - interface cp_remove_block - module procedure cp_sp_remove_block - end interface - interface cp_dealloc - module procedure cp_sp_array_dealloc - end interface - interface cp_set_to - module procedure cp_sp_set_to - end interface - interface cp_get - module procedure cp_sp_get - end interface + INTERFACE cp_retain + MODULE PROCEDURE cp_sp_retain + END INTERFACE + INTERFACE cp_release + MODULE PROCEDURE cp_sp_release, cp_sp_array_release + END INTERFACE + INTERFACE cp_get_matrix + MODULE PROCEDURE cp_sp_get_matrix + END INTERFACE + INTERFACE cp_flush_cache + MODULE PROCEDURE cp_sp_flush_cache + END INTERFACE + INTERFACE cp_get_local_block + MODULE PROCEDURE cp_sp_get_local_block + END INTERFACE + INTERFACE cp_release_block + MODULE PROCEDURE cp_sp_block_handle_release + END INTERFACE + INTERFACE cp_set_local_block + MODULE PROCEDURE cp_sp_set_local_block + END INTERFACE + INTERFACE cp_remove_block + MODULE PROCEDURE cp_sp_remove_block + END INTERFACE + INTERFACE cp_dealloc + MODULE PROCEDURE cp_sp_array_dealloc + END INTERFACE + INTERFACE cp_set_to + MODULE PROCEDURE cp_sp_set_to + END INTERFACE + INTERFACE cp_get + MODULE PROCEDURE cp_sp_get + END INTERFACE !*** !**************************************************************************** @@ -150,17 +168,17 @@ module cp_block_matrix !! !! SOURCE !*************************************************************************** - type cp_block_matrix_type - logical :: initialized - logical :: frozen - logical :: should_dealloc_matrix - logical :: b_rep_is_primary - logical :: b_i_rep_in_sync - logical :: cache_is_valid - type(cp_b_matrix_struct_type), pointer :: matrix_struct - integer :: ref_count, id_nr - type(real_matrix_type), pointer :: sm - end type cp_block_matrix_type + TYPE cp_block_matrix_type + LOGICAL :: initialized + LOGICAL :: frozen + LOGICAL :: should_dealloc_matrix + LOGICAL :: b_rep_is_primary + LOGICAL :: b_i_rep_in_sync + LOGICAL :: cache_is_valid + TYPE(cp_b_matrix_struct_type), POINTER :: matrix_struct + INTEGER :: ref_count, id_nr + TYPE(real_matrix_type), POINTER :: sm + END TYPE cp_block_matrix_type !!*** !**************************************************************************** @@ -186,9 +204,9 @@ module cp_block_matrix !! !! SOURCE !*************************************************************************** - type cp_block_matrix_p_type - type(cp_block_matrix_type), pointer :: matrix - end type cp_block_matrix_p_type + TYPE cp_block_matrix_p_type + TYPE(cp_block_matrix_type), POINTER :: matrix + END TYPE cp_block_matrix_p_type !!*** !**************************************************************************** @@ -217,17 +235,17 @@ module cp_block_matrix !! !! SOURCE !*************************************************************************** - type cp_sp_block_handle_type - type(cp_block_matrix_type), pointer :: matrix - integer :: block_row, block_col - character :: trans,trans_to_do - real(kind=wp), dimension(:,:), pointer :: block_val - logical :: should_dealloc_data, initialized - end type cp_sp_block_handle_type + TYPE cp_sp_block_handle_type + TYPE(cp_block_matrix_type), POINTER :: matrix + INTEGER :: block_row, block_col + CHARACTER :: trans,trans_to_do + REAL(kind=wp), DIMENSION(:,:), POINTER :: block_val + LOGICAL :: should_dealloc_data, initialized + END TYPE cp_sp_block_handle_type !!*** !**************************************************************************** -contains +CONTAINS !!****f* cp_block_matrix/cp_sp_create [1.0] * !! @@ -272,54 +290,54 @@ contains !! 4.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_create(matrix, matrix_struct, u_matrix, & + SUBROUTINE cp_sp_create(matrix, matrix_struct, u_matrix, & should_dealloc_matrix, b_rep_is_primary, allocate_nonsparse_blocks, error) - type(cp_block_matrix_type), pointer :: matrix - type(cp_b_matrix_struct_type), intent(in), target :: matrix_struct - type(real_matrix_type), optional, intent(in), target :: u_matrix - logical, intent(in), optional :: should_dealloc_matrix, b_rep_is_primary,& + TYPE(cp_block_matrix_type), POINTER :: matrix + TYPE(cp_b_matrix_struct_type), INTENT(in), TARGET :: matrix_struct + TYPE(real_matrix_type), OPTIONAL, INTENT(in), TARGET :: u_matrix + LOGICAL, INTENT(in), OPTIONAL :: should_dealloc_matrix, b_rep_is_primary,& allocate_nonsparse_blocks - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_create',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_create',& routineP=moduleN//':'//routineN - character(len=10) :: m_symm - type(cp_b_dims_type), pointer :: b_dims - integer, save :: last_id_nr=0 - integer :: stat, block_cols, block_rows - failure=.false. + CHARACTER(len=10) :: m_symm + TYPE(cp_b_dims_type), POINTER :: b_dims + INTEGER, SAVE :: last_id_nr=0 + INTEGER :: stat, block_cols, block_rows + failure=.FALSE. - allocate(matrix,stat=stat) + ALLOCATE(matrix,stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (.not. failure) then + IF (.NOT. failure) THEN last_id_nr=last_id_nr+1 matrix%id_nr=last_id_nr - matrix%frozen=.false. - matrix%cache_is_valid=.false. - matrix%should_dealloc_matrix=.true. - if (present(should_dealloc_matrix)) & + matrix%frozen=.FALSE. + matrix%cache_is_valid=.FALSE. + matrix%should_dealloc_matrix=.TRUE. + IF (PRESENT(should_dealloc_matrix)) & matrix%should_dealloc_matrix=should_dealloc_matrix - matrix%b_rep_is_primary = .true. - if (present(b_rep_is_primary)) matrix%b_rep_is_primary=b_rep_is_primary - matrix%b_i_rep_in_sync = .false. + matrix%b_rep_is_primary = .TRUE. + IF (PRESENT(b_rep_is_primary)) matrix%b_rep_is_primary=b_rep_is_primary + matrix%b_i_rep_in_sync = .FALSE. matrix%matrix_struct => matrix_struct - call cp_retain(matrix%matrix_struct,error=error) + CALL cp_retain(matrix%matrix_struct,error=error) matrix%ref_count=1 - nullify(matrix%sm) - matrix%initialized=.true. - if (present(u_matrix)) then + NULLIFY(matrix%sm) + matrix%initialized=.TRUE. + IF (PRESENT(u_matrix)) THEN matrix%sm => u_matrix - else - if (matrix%matrix_struct%symmetric) then + ELSE + IF (matrix%matrix_struct%symmetric) THEN m_symm='symmetric' - else - m_symm='none' - end if + ELSE + m_symm='NONE' + END IF b_dims => matrix%matrix_struct%b_dims - block_rows=size(b_dims%block_begins_at_row)-1 - block_cols=size(b_dims%block_begins_at_col)-1 - call allocate_matrix(matrix%sm,& + block_rows=SIZE(b_dims%block_begins_at_row)-1 + block_cols=SIZE(b_dims%block_begins_at_col)-1 + CALL allocate_matrix(matrix%sm,& nrow=b_dims%block_begins_at_row(block_rows+1)-1,& ncol=b_dims%block_begins_at_col(block_cols+1)-1,& nblock_row=block_rows,& @@ -330,14 +348,14 @@ contains last_col=b_dims%block_begins_at_col(2:(block_cols+1))-1,& matrix_name='matrix'//cp_to_string(matrix%id_nr),& matrix_symmetry=m_symm) - end if - if (present(allocate_nonsparse_blocks)) then - if (allocate_nonsparse_blocks) then - call cp_sp_alloc_nonsparse_blocks(matrix,error=error) - end if - end if - end if - end subroutine cp_sp_create + END IF + IF (PRESENT(allocate_nonsparse_blocks)) THEN + IF (allocate_nonsparse_blocks) THEN + CALL cp_sp_alloc_nonsparse_blocks(matrix,error=error) + END IF + END IF + END IF + END SUBROUTINE cp_sp_create !*************************************************************************** !!****f* cp_block_matrix/cp_sp_dealloc [1.0] * @@ -369,35 +387,35 @@ contains !! 4.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_dealloc(matrix, error) - type(cp_block_matrix_type), pointer :: matrix - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_dealloc(matrix, error) + TYPE(cp_block_matrix_type), POINTER :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_dealloc',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_dealloc',& routineP=moduleN//':'//routineN - integer :: stat - failure=.false. + INTEGER :: stat + failure=.FALSE. - if (associated(matrix)) then + IF (ASSOCIATED(matrix)) THEN CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) CPPreconditionNoFail(matrix%ref_count==0,cp_warning_level,routineP,error) - if (.not. failure) then - matrix%initialized=.false. - call cp_release(matrix%matrix_struct, error=error) - nullify(matrix%matrix_struct) - if (matrix%should_dealloc_matrix) then - if (associated(matrix%sm)) then - call deallocate_matrix(matrix%sm) - end if - else - nullify(matrix%sm) - end if - deallocate(matrix,stat=stat) + IF (.NOT. failure) THEN + matrix%initialized=.FALSE. + CALL cp_release(matrix%matrix_struct, error=error) + NULLIFY(matrix%matrix_struct) + IF (matrix%should_dealloc_matrix) THEN + IF (ASSOCIATED(matrix%sm)) THEN + CALL deallocate_matrix(matrix%sm) + END IF + ELSE + NULLIFY(matrix%sm) + END IF + DEALLOCATE(matrix,stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - end if - end if - end subroutine cp_sp_dealloc + END IF + END IF + END SUBROUTINE cp_sp_dealloc !*************************************************************************** !!****f* cp_block_matrix/cp_sp_retain [1.0] * @@ -430,23 +448,23 @@ contains !! 4.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_retain(matrix, error) - type(cp_block_matrix_type), intent(inout), target :: matrix - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_retain(matrix, error) + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_retain',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_retain',& routineP=moduleN//':'//routineN - type(cp_block_matrix_type), pointer :: m_ptr - failure=.false. + TYPE(cp_block_matrix_type), POINTER :: m_ptr + failure=.FALSE. m_ptr => matrix - CPPrecondition(associated(m_ptr),cp_failure_level,routineP,error,failure) - if (.not.failure) then + CPPrecondition(ASSOCIATED(m_ptr),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN CPPreconditionNoFail(matrix%ref_count>0,cp_warning_level,routineP,error) matrix%ref_count=matrix%ref_count+1 - end if - end subroutine cp_sp_retain + END IF + END SUBROUTINE cp_sp_retain !*************************************************************************** !!****f* cp_block_matrix/cp_sp_release [1.0] * @@ -479,25 +497,25 @@ contains !! 4.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_release(matrix, error) - type(cp_block_matrix_type), pointer :: matrix - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_release(matrix, error) + TYPE(cp_block_matrix_type), POINTER :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_release',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_release',& routineP=moduleN//':'//routineN - integer :: stat - failure=.false. + INTEGER :: stat + failure=.FALSE. - if (associated(matrix)) then + IF (ASSOCIATED(matrix)) THEN CPPreconditionNoFail(matrix%ref_count>0,cp_warning_level,routineP,error) matrix%ref_count=matrix%ref_count-1 - if (matrix%ref_count==0) then - call cp_sp_dealloc(matrix,error=error) - end if - end if - nullify(matrix) - end subroutine cp_sp_release + IF (matrix%ref_count==0) THEN + CALL cp_sp_dealloc(matrix,error=error) + END IF + END IF + NULLIFY(matrix) + END SUBROUTINE cp_sp_release !*************************************************************************** !!****f* cp_block_matrix/cp_sp_get_matrix [1.0] * @@ -530,21 +548,21 @@ contains !! 4.2002 created [fawzi] !! !!*** ********************************************************************** - function cp_sp_get_matrix(matrix, error) result(res) - type(cp_block_matrix_type), pointer :: matrix - type(real_matrix_type), pointer ::res - type(cp_error_type), optional, intent(inout) :: error + FUNCTION cp_sp_get_matrix(matrix, error) RESULT(res) + TYPE(cp_block_matrix_type), POINTER :: matrix + TYPE(real_matrix_type), POINTER ::res + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_get_matrix',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_get_matrix',& routineP=moduleN//':'//routineN - type(cp_block_matrix_type), pointer :: m_ptr - failure=.false. + TYPE(cp_block_matrix_type), POINTER :: m_ptr + failure=.FALSE. - CPPrecondition(associated(matrix),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) res => matrix%sm - end function cp_sp_get_matrix + END FUNCTION cp_sp_get_matrix !*************************************************************************** !================ block matrix op ============= @@ -582,27 +600,27 @@ contains !! 07.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_set_b_rep(matrix,error) - type(cp_block_matrix_type), pointer :: matrix - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_set_b_rep(matrix,error) + TYPE(cp_block_matrix_type), POINTER :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_set_b_rep',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_set_b_rep',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - CPPrecondition(associated(matrix),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then - if (.not.matrix%b_rep_is_primary) then - if (cp_debug .and. debug_this_module) then - call mp_sync(matrix%matrix_struct%distribution%para_env%group) - end if - matrix%b_rep_is_primary=.true. - end if - end if - end subroutine cp_sp_set_b_rep + IF (.not.failure) THEN + IF (.not.matrix%b_rep_is_primary) THEN + IF (cp_debug .AND. debug_this_module) THEN + CALL mp_sync(matrix%matrix_struct%distribution%para_env%group) + END IF + matrix%b_rep_is_primary=.TRUE. + END IF + END IF + END SUBROUTINE cp_sp_set_b_rep !*************************************************************************** !!****f* cp_block_matrix/cp_sp_set_i_rep [1.0] * @@ -630,27 +648,27 @@ contains !! 07.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_set_i_rep(matrix,error) - type(cp_block_matrix_type), pointer :: matrix - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_set_i_rep(matrix,error) + TYPE(cp_block_matrix_type), POINTER :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_set_b_rep',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_set_b_rep',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - CPPrecondition(associated(matrix),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then - if (matrix%b_rep_is_primary) then - if (cp_debug .and. debug_this_module) then - call mp_sync(matrix%matrix_struct%distribution%para_env%group) - end if - matrix%b_rep_is_primary=.false. - end if - end if - end subroutine cp_sp_set_i_rep + IF (.not.failure) THEN + IF (matrix%b_rep_is_primary) THEN + IF (cp_debug .AND. debug_this_module) THEN + CALL mp_sync(matrix%matrix_struct%distribution%para_env%group) + END IF + matrix%b_rep_is_primary=.FALSE. + END IF + END IF + END SUBROUTINE cp_sp_set_i_rep !*************************************************************************** !!****f* cp_block_matrix/cp_sp_flush_cache [1.0] * @@ -679,37 +697,37 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_sp_flush_cache(matrix,flush_secondary_rep,error) - type(cp_block_matrix_type), intent(in) :: matrix - logical, optional, intent(in) :: flush_secondary_rep - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_flush_cache(matrix,flush_secondary_rep,error) + TYPE(cp_block_matrix_type), INTENT(in) :: matrix + LOGICAL, OPTIONAL, INTENT(in) :: flush_secondary_rep + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: brow,bcol, mepos - character(len=*), parameter :: routineN='cp_sp_flush_cache',& + LOGICAL :: failure + INTEGER :: brow,bcol, mepos + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_flush_cache',& routineP=moduleN//':'//routineN - type(cp_matrix_block_iterator) :: b_iterator - type(cp_b_distribution_type), pointer :: distribution - nullify(distribution) - failure=.false. + TYPE(cp_matrix_block_iterator) :: b_iterator + TYPE(cp_b_distribution_type), POINTER :: distribution + NULLIFY(distribution) + failure=.FALSE. CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - call cp_sm_b_i_init(b_iterator,matrix=matrix%sm,error=error) + IF (.NOT. failure) THEN + CALL cp_sm_b_i_init(b_iterator,matrix=matrix%sm,error=error) distribution => matrix%matrix_struct%distribution mepos=matrix%matrix_struct%distribution%para_env%mepos - CPPrecondition(associated(distribution),cp_failure_level,routineP,error,failure) - do - if (.not.cp_sm_b_i_next(b_iterator,block_row=brow,& - block_col=bcol)) exit - if (distribution%block_owner(brow,bcol) /= mepos) then - call remove_block_node(matrix=matrix%sm, block_row=brow,& + CPPrecondition(ASSOCIATED(distribution),cp_failure_level,routineP,error,failure) + DO + IF (.not.cp_sm_b_i_next(b_iterator,block_row=brow,& + block_col=bcol)) EXIT + IF (distribution%block_owner(brow,bcol) /= mepos) THEN + CALL remove_block_node(matrix=matrix%sm, block_row=brow,& block_col=bcol,error=error) - end if - end do - call cp_sm_b_i_dealloc_ref(b_iterator,error=error) - end if - end subroutine cp_sp_flush_cache + END IF + END DO + CALL cp_sm_b_i_dealloc_ref(b_iterator,error=error) + END IF + END SUBROUTINE cp_sp_flush_cache !*************************************************************************** !!****f* cp_block_matrix/cp_sp_block_handle_init [1.0] * @@ -741,23 +759,23 @@ contains !! 4.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_block_handle_init(block_handle,error) - type(cp_sp_block_handle_type), intent(out) :: block_handle - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_block_handle_init(block_handle,error) + TYPE(cp_sp_block_handle_type), INTENT(out) :: block_handle + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_block_handle_init',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_block_handle_init',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. block_handle%block_col=-1 block_handle%block_row=-1 block_handle%trans='N' block_handle%trans_to_do='N' - block_handle%should_dealloc_data=.false. - nullify(block_handle%block_val, block_handle%matrix) - block_handle%initialized=.true. -end subroutine cp_sp_block_handle_init + block_handle%should_dealloc_data=.FALSE. + NULLIFY(block_handle%block_val, block_handle%matrix) + block_handle%initialized=.TRUE. +END SUBROUTINE cp_sp_block_handle_init !*************************************************************************** !!****f* cp_block_matrix_type/cp_sp_get_local_block [1.0] * @@ -815,102 +833,102 @@ end subroutine cp_sp_block_handle_init !! none !! !!*** ********************************************************************** - subroutine cp_sp_get_local_block(matrix,block_row,block_col,& + SUBROUTINE cp_sp_get_local_block(matrix,block_row,block_col,& block_handle,trans,trans_to_do,block_val,& local_owner,owner,alloc_block,error) - type(cp_block_matrix_type), intent(inout), target :: matrix - integer, intent(in) :: block_row,block_col - type(cp_sp_block_handle_type), intent(inout) :: block_handle - character(len=1), intent(in),optional :: trans - character(len=1), intent(out),optional :: trans_to_do - real(kind=wp), dimension(:,:), optional, pointer :: block_val - logical, intent(out), optional :: local_owner - integer, intent(out), optional :: owner - logical, intent(in), optional :: alloc_block - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + INTEGER, INTENT(in) :: block_row,block_col + TYPE(cp_sp_block_handle_type), INTENT(inout) :: block_handle + CHARACTER(len=1), INTENT(in),OPTIONAL :: trans + CHARACTER(len=1), INTENT(out),OPTIONAL :: trans_to_do + REAL(kind=wp), DIMENSION(:,:), OPTIONAL, POINTER :: block_val + LOGICAL, INTENT(out), OPTIONAL :: local_owner + INTEGER, INTENT(out), OPTIONAL :: owner + LOGICAL, INTENT(in), OPTIONAL :: alloc_block + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_get_local_block',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_get_local_block',& routineP=moduleN//':'//routineN - integer :: i, stat - real(kind=wp), dimension(:,:), pointer :: tmp_block - failure=.false. + INTEGER :: i, stat + REAL(kind=wp), DIMENSION(:,:), POINTER :: tmp_block + failure=.FALSE. CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) CPPreconditionNoFail(block_handle%initialized,cp_warning_level,routineP,error) - CPPreconditionNoFail(.not.associated(block_handle%block_val),cp_warning_level,routineP,error) - if (.not. failure) then + CPPreconditionNoFail(.not.ASSOCIATED(block_handle%block_val),cp_warning_level,routineP,error) + IF (.NOT. failure) THEN CPPreconditionNoFail(.not.matrix%frozen,cp_warning_level,routineP,error) block_handle%trans='N' - if (present(trans)) block_handle%trans=trans - call uppercase(block_handle%trans) + IF (PRESENT(trans)) block_handle%trans=trans + CALL uppercase(block_handle%trans) block_handle%trans_to_do=block_handle%trans - call cp_assert(block_handle%trans=='N'.or.block_handle%trans=='T',& + CALL cp_assert(block_handle%trans=='N'.or.block_handle%trans=='T',& cp_warning_level,cp_precondition_failed,routineP,& "unknown requested transposition '"//block_handle%trans//"' in "//& CPSourceFileRef,& error=error) block_handle%block_row=block_row block_handle%block_col=block_col - if (matrix%matrix_struct%symmetric .and. block_row > block_col) then - if (block_handle%trans=='N') then + IF (matrix%matrix_struct%symmetric .AND. block_row > block_col) THEN + IF (block_handle%trans=='N') THEN block_handle%trans_to_do='T' - else + ELSE block_handle%trans_to_do='N' - end if - call get_block_node(matrix%sm, block_row=block_handle%block_col, & - block_col=block_handle%block_row, block=tmp_block) - if (present(alloc_block)) then - if (alloc_block .and. .not.associated(tmp_block)) then - call add_block_node(matrix%sm,& + END IF + CALL get_block_node(matrix%sm, block_row=block_handle%block_col, & + block_col=block_handle%block_row, BLOCK=tmp_block) + IF (PRESENT(alloc_block)) THEN + IF (alloc_block .AND. .not.ASSOCIATED(tmp_block)) THEN + CALL add_block_node(matrix%sm,& block_row=block_handle%block_col,& - block_col=block_handle%block_row, block=tmp_block) - end if - end if - else - call get_block_node(matrix%sm, block_row=block_handle%block_row, & - block_col=block_handle%block_col, block=tmp_block) - if (present(alloc_block)) then - if (alloc_block .and. .not.associated(tmp_block)) then - call add_block_node(matrix%sm, block_row=block_handle%block_row,& - block_col=block_handle%block_col, block=tmp_block) - end if - end if - end if - if (present(trans_to_do).or.(.not.present(block_val)).or.& - block_handle%trans_to_do=='N') then + block_col=block_handle%block_row, BLOCK=tmp_block) + END IF + END IF + ELSE + CALL get_block_node(matrix%sm, block_row=block_handle%block_row, & + block_col=block_handle%block_col, BLOCK=tmp_block) + IF (PRESENT(alloc_block)) THEN + IF (alloc_block .AND. .not.ASSOCIATED(tmp_block)) THEN + CALL add_block_node(matrix%sm, block_row=block_handle%block_row,& + block_col=block_handle%block_col, BLOCK=tmp_block) + END IF + END IF + END IF + IF (PRESENT(trans_to_do).OR.(.not.PRESENT(block_val)).OR.& + block_handle%trans_to_do=='N') THEN block_handle%block_val => tmp_block - block_handle%should_dealloc_data=.false. - else + block_handle%should_dealloc_data=.FALSE. + ELSE block_handle%trans_to_do='N' - if (associated(tmp_block)) then - allocate(block_handle%block_val(size(tmp_block,2),& - size(tmp_block,1)), stat=stat) + IF (ASSOCIATED(tmp_block)) THEN + ALLOCATE(block_handle%block_val(SIZE(tmp_block,2),& + SIZE(tmp_block,1)), stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (.not.failure) then - do i=1,size(tmp_block,2) + IF (.not.failure) THEN + DO i=1,SIZE(tmp_block,2) block_handle%block_val(i,:)=tmp_block(:,i) - end do - end if - else - nullify(block_handle%block_val) - end if - block_handle%should_dealloc_data=.true. - end if - if (present(trans_to_do)) trans_to_do = block_handle%trans_to_do - if (present(block_val)) block_val => block_handle%block_val - if (present(local_owner)) then + END DO + END IF + ELSE + NULLIFY(block_handle%block_val) + END IF + block_handle%should_dealloc_data=.TRUE. + END IF + IF (PRESENT(trans_to_do)) trans_to_do = block_handle%trans_to_do + IF (PRESENT(block_val)) block_val => block_handle%block_val + IF (PRESENT(local_owner)) THEN local_owner=matrix%matrix_struct%distribution%block_owner& (block_handle%block_row,block_handle%block_col)==& matrix%matrix_struct%distribution%para_env%mepos - end if - if (present(owner)) then + END IF + IF (PRESENT(owner)) THEN owner=matrix%matrix_struct%distribution%block_owner& (block_handle%block_row,block_handle%block_col) - end if - block_handle%initialized=.true. - end if - end subroutine cp_sp_get_local_block + END IF + block_handle%initialized=.TRUE. + END IF + END SUBROUTINE cp_sp_get_local_block !*************************************************************************** !!****f* cp_block_matrix/cp_sp_block_handle_release [1.0] * @@ -950,48 +968,48 @@ end subroutine cp_sp_block_handle_init !! none !! !!*** ********************************************************************** - subroutine cp_sp_block_handle_release(block_handle,changed_values,error) - type(cp_sp_block_handle_type), intent(inout) :: block_handle - logical, intent(in) :: changed_values - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_block_handle_release(block_handle,changed_values,error) + TYPE(cp_sp_block_handle_type), INTENT(inout) :: block_handle + LOGICAL, INTENT(in) :: changed_values + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: stat - character(len=*), parameter :: routineN='cp_sp_block_handle_release',& + LOGICAL :: failure + INTEGER :: stat + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_block_handle_release',& routineP=moduleN//':'//routineN - character :: tt - failure=.false. + CHARACTER :: tt + failure=.FALSE. CPPrecondition(block_handle%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (changed_values.and.block_handle%matrix%frozen) then - call cp_assert(.false.,& + IF (.NOT. failure) THEN + IF (changed_values.and.block_handle%matrix%frozen) THEN + CALL cp_assert(.FALSE.,& cp_warning_level,cp_assertion_failed,routineP,& "changed values in frozen matrix",error) - block_handle%matrix%frozen=.false. - end if - if (changed_values .and. block_handle%should_dealloc_data) then - if (block_handle%trans_to_do==block_handle%trans) then + block_handle%matrix%frozen=.FALSE. + END IF + IF (changed_values .AND. block_handle%should_dealloc_data) THEN + IF (block_handle%trans_to_do==block_handle%trans) THEN tt='N' - else + ELSE tt='T' - end if - call cp_sp_set_local_block(block_handle%matrix, & + END IF + CALL cp_sp_set_local_block(block_handle%matrix, & block_row=block_handle%block_row,& block_col=block_handle%block_col,& - trans=tt,local_scratch=.true.,& + trans=tt,local_scratch=.TRUE.,& block_val=block_handle%block_val,& error=error) - end if - if (block_handle%should_dealloc_data) then - if (associated(block_handle%block_val)) then - deallocate(block_handle%block_val,stat=stat) + END IF + IF (block_handle%should_dealloc_data) THEN + IF (ASSOCIATED(block_handle%block_val)) THEN + DEALLOCATE(block_handle%block_val,stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - end if - end if - nullify(block_handle%block_val) - end if - end subroutine cp_sp_block_handle_release + END IF + END IF + NULLIFY(block_handle%block_val) + END IF + END SUBROUTINE cp_sp_block_handle_release !*************************************************************************** !!****f* cp_block_matrix/cp_sp_set_local_block [1.0] * @@ -1035,62 +1053,62 @@ end subroutine cp_sp_block_handle_init !! none !! !!*** ********************************************************************** - subroutine cp_sp_set_local_block(matrix,block_row,block_col,block_val,& + SUBROUTINE cp_sp_set_local_block(matrix,block_row,block_col,block_val,& trans,local_scratch,error) - type(cp_block_matrix_type), intent(inout), target :: matrix - integer, intent(in) :: block_row, block_col - real(kind=wp), intent(in), dimension(:,:), target :: block_val - character, intent(in), optional :: trans - logical, intent(in), optional :: local_scratch - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + INTEGER, INTENT(in) :: block_row, block_col + REAL(kind=wp), INTENT(in), DIMENSION(:,:), TARGET :: block_val + CHARACTER, INTENT(in), OPTIONAL :: trans + LOGICAL, INTENT(in), OPTIONAL :: local_scratch + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_set_local_block',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_set_local_block',& routineP=moduleN//':'//routineN - character :: t_to_do - integer :: b_row,b_col, i, stat - real(kind=wp), dimension(:,:), pointer :: tmp_block - failure=.false. + CHARACTER :: t_to_do + INTEGER :: b_row,b_col, i, stat + REAL(kind=wp), DIMENSION(:,:), POINTER :: tmp_block + failure=.FALSE. CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_assert(.not.matrix%frozen,& + IF (.not.failure) THEN + CALL cp_assert(.not.matrix%frozen,& cp_warning_level,cp_assertion_failed,routineP,& "changed values in frozen matrix",error) - matrix%frozen=.false. - end if - if (.not. failure) then + matrix%frozen=.FALSE. + END IF + IF (.NOT. failure) THEN t_to_do='N' - if (present(trans)) t_to_do=trans - call uppercase(t_to_do) + IF (PRESENT(trans)) t_to_do=trans + CALL uppercase(t_to_do) b_row=block_col b_row=block_row - if (matrix%matrix_struct%symmetric.and.block_row > block_col) then - if (t_to_do=='N') then + IF (matrix%matrix_struct%symmetric.and.block_row > block_col) THEN + IF (t_to_do=='N') THEN t_to_do='T' - else + ELSE t_to_do='N' - end if + END IF b_row=block_row b_row=block_col - end if - if (t_to_do=='T') then - allocate(tmp_block(size(block_val,2),size(block_val,1)),stat=stat) + END IF + IF (t_to_do=='T') THEN + ALLOCATE(tmp_block(SIZE(block_val,2),SIZE(block_val,1)),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - do i=1,size(block_val,2) + DO i=1,SIZE(block_val,2) tmp_block(i,:)=block_val(:,i) - end do - call put_block_node(matrix%sm, block_row=b_row,& - block_col=b_col, block=tmp_block) - deallocate(tmp_block,stat=stat) + END DO + CALL put_block_node(matrix%sm, block_row=b_row,& + block_col=b_col, BLOCK=tmp_block) + DEALLOCATE(tmp_block,stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - else + ELSE tmp_block => block_val - call put_block_node(matrix%sm, block_row=b_row,& - block_col=b_col, block=tmp_block) - end if - endif - end subroutine cp_sp_set_local_block + CALL put_block_node(matrix%sm, block_row=b_row,& + block_col=b_col, BLOCK=tmp_block) + END IF + ENDIF + END SUBROUTINE cp_sp_set_local_block !*************************************************************************** !!****f* cp_block_matrix/cp_sp_remove_block [1.0] * @@ -1125,28 +1143,28 @@ end subroutine cp_sp_block_handle_init !! none !! !!*** ********************************************************************** - subroutine cp_sp_remove_block(matrix,block_row, block_col,error) - type(cp_block_matrix_type), intent(inout), target :: matrix - integer, intent(in):: block_col, block_row - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_remove_block(matrix,block_row, block_col,error) + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + INTEGER, INTENT(in):: block_col, block_row + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_remove_block',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_remove_block',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - CPAssert(.false.,cp_failure_level,routineP,error,failure) - if (matrix%matrix_struct%symmetric.and.block_row > block_col) then - call remove_block_node(matrix%sm,block_row=block_col,& + IF (.NOT. failure) THEN + CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) + IF (matrix%matrix_struct%symmetric.and.block_row > block_col) THEN + CALL remove_block_node(matrix%sm,block_row=block_col,& block_col=block_row, error=error) - else - call remove_block_node(matrix%sm,block_row=block_row,& + ELSE + CALL remove_block_node(matrix%sm,block_row=block_row,& block_col=block_col, error=error) - end if - end if - end subroutine cp_sp_remove_block + END IF + END IF + END SUBROUTINE cp_sp_remove_block !*************************************************************************** !!****f* cp_block_matrix/cp_sp_array_create [1.0] * !! @@ -1188,34 +1206,34 @@ end subroutine cp_sp_block_handle_init !! 4.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_array_create(matrixes, n_matrixes, matrix_struct, & + SUBROUTINE cp_sp_array_create(matrixes, n_matrixes, matrix_struct, & b_rep_is_primary, allocate_nonsparse_blocks, error) - type(cp_block_matrix_p_type), dimension(:), pointer :: matrixes - type(cp_b_matrix_struct_type), intent(in), target :: matrix_struct - integer, intent(in) :: n_matrixes - logical, intent(in), optional :: b_rep_is_primary,& + TYPE(cp_block_matrix_p_type), DIMENSION(:), POINTER :: matrixes + TYPE(cp_b_matrix_struct_type), INTENT(in), TARGET :: matrix_struct + INTEGER, INTENT(in) :: n_matrixes + LOGICAL, INTENT(in), OPTIONAL :: b_rep_is_primary,& allocate_nonsparse_blocks - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_array_create',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_array_create',& routineP=moduleN//':'//routineN - integer :: stat,i - failure=.false. + INTEGER :: stat,i + failure=.FALSE. - allocate(matrixes(n_matrixes),stat=stat) + ALLOCATE(matrixes(n_matrixes),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (.not.failure) then - do i=1,n_matrixes - nullify(matrixes(i)%matrix) - call cp_sp_create(matrixes(i)%matrix,& + IF (.not.failure) THEN + DO i=1,n_matrixes + NULLIFY(matrixes(i)%matrix) + CALL cp_sp_create(matrixes(i)%matrix,& matrix_struct=matrix_struct,& b_rep_is_primary=b_rep_is_primary,& allocate_nonsparse_blocks=allocate_nonsparse_blocks,& error=error) - end do - end if - end subroutine cp_sp_array_create + END DO + END IF + END SUBROUTINE cp_sp_array_create !!****f* cp_block_matrix/cp_sp_dealloc_m_array [1.0] * !! @@ -1240,25 +1258,25 @@ end subroutine cp_sp_block_handle_init !! 4.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_array_dealloc(m_array, error) - type(cp_block_matrix_p_type), dimension(:), pointer :: m_array - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sp_array_dealloc(m_array, error) + TYPE(cp_block_matrix_p_type), DIMENSION(:), POINTER :: m_array + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_array_dealloc',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_array_dealloc',& routineP=moduleN//':'//routineN - integer :: i, stat - failure=.false. + INTEGER :: i, stat + failure=.FALSE. - if (associated(m_array)) then - do i=1,size(m_array) - call cp_release(m_array(i)%matrix,error=error) - end do - deallocate(m_array,stat=stat) + IF (ASSOCIATED(m_array)) THEN + DO i=1,SIZE(m_array) + CALL cp_release(m_array(i)%matrix,error=error) + END DO + DEALLOCATE(m_array,stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - nullify(m_array) - end subroutine cp_sp_array_dealloc + END IF + NULLIFY(m_array) + END SUBROUTINE cp_sp_array_dealloc !*************************************************************************** !!****f* cp_block_matrix/cp_sp_array_release [1.0] * @@ -1290,21 +1308,21 @@ end subroutine cp_sp_block_handle_init !! 4.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_array_release(array,error) - type(cp_block_matrix_p_type), dimension(:), intent(inout) :: array - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_array_release(array,error) + TYPE(cp_block_matrix_p_type), DIMENSION(:), INTENT(inout) :: array + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_array_release',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_array_release',& routineP=moduleN//':'//routineN - integer :: i - failure=.false. + INTEGER :: i + failure=.FALSE. - do i=1,size(array) - call cp_release(array(i)%matrix,error=error) - nullify(array(i)%matrix) - end do -end subroutine cp_sp_array_release + DO i=1,SIZE(array) + CALL cp_release(array(i)%matrix,error=error) + NULLIFY(array(i)%matrix) + END DO +END SUBROUTINE cp_sp_array_release !*************************************************************************** !!****f* cp_block_matrix/cp_sp_alloc_nonsparse_blocks * @@ -1337,23 +1355,23 @@ end subroutine cp_sp_array_release !! 5.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_alloc_nonsparse_blocks(matrix,error) - type(cp_block_matrix_type), intent(inout), target :: matrix - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_alloc_nonsparse_blocks(matrix,error) + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_alloc_nonsparse_blocks',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_alloc_nonsparse_blocks',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - call cp_sm_alloc_nonsparse_blocks(matrix%sm,& + IF (.NOT. failure) THEN + CALL cp_sm_alloc_nonsparse_blocks(matrix%sm,& m_struct=matrix%matrix_struct,& para_env=matrix%matrix_struct%distribution%para_env,& error=error) - end if -end subroutine cp_sp_alloc_nonsparse_blocks + END IF +END SUBROUTINE cp_sp_alloc_nonsparse_blocks !*************************************************************************** !============= sparsity =========== @@ -1381,21 +1399,21 @@ end subroutine cp_sp_alloc_nonsparse_blocks !! 07.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_update_sparsity(matrix,error) - type(cp_block_matrix_type), intent(inout), target :: matrix - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_update_sparsity(matrix,error) + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_update_sparsity',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_update_sparsity',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (.not. failure) then - call cp_unimplemented_error(fromWhere=routineP, & + IF (.NOT. failure) THEN + CALL cp_unimplemented_error(fromWhere=routineP, & message="update sparsity", error=error) ! to do - end if -end subroutine cp_sp_update_sparsity + END IF +END SUBROUTINE cp_sp_update_sparsity !*************************************************************************** !!****f* cp_block_matrix/cp_sp_check_sparsity [1.0] * @@ -1421,21 +1439,21 @@ end subroutine cp_sp_update_sparsity !! 07.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_check_sparsity(matrix,error) - type(cp_block_matrix_type), intent(inout), target :: matrix - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_check_sparsity(matrix,error) + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_check_sparsity',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_check_sparsity',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (.not. failure) then - call cp_unimplemented_error(fromWhere=routineP, & + IF (.NOT. failure) THEN + CALL cp_unimplemented_error(fromWhere=routineP, & message="check sparsity", error=error) ! to do - end if -end subroutine cp_sp_check_sparsity + END IF +END SUBROUTINE cp_sp_check_sparsity !*************************************************************************** !!****f* cp_block_matrix/cp_sp_enforce_sparsity [1.0] * @@ -1462,21 +1480,21 @@ end subroutine cp_sp_check_sparsity !! 07.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_enforce_sparsity(matrix,error) - type(cp_block_matrix_type), intent(inout), target :: matrix - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_enforce_sparsity(matrix,error) + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_enforce_sparsity',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_enforce_sparsity',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (.not. failure) then - call cp_unimplemented_error(fromWhere=routineP, & + IF (.NOT. failure) THEN + CALL cp_unimplemented_error(fromWhere=routineP, & message="enforce sparsity", error=error) ! to do - end if -end subroutine cp_sp_enforce_sparsity + END IF +END SUBROUTINE cp_sp_enforce_sparsity !*************************************************************************** !============= distribution =========== @@ -1504,21 +1522,21 @@ end subroutine cp_sp_enforce_sparsity !! 07.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_check_distribution(matrix,error) - type(cp_block_matrix_type), intent(inout), target :: matrix - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_check_distribution(matrix,error) + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_check_distribution',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_check_distribution',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (.not. failure) then - call cp_unimplemented_error(fromWhere=routineP, & + IF (.NOT. failure) THEN + CALL cp_unimplemented_error(fromWhere=routineP, & message="check distribution", error=error) ! to do - end if -end subroutine cp_sp_check_distribution + END IF +END SUBROUTINE cp_sp_check_distribution !*************************************************************************** !!****f* cp_block_matrix/cp_sp_get [1.0] * @@ -1571,49 +1589,49 @@ end subroutine cp_sp_check_distribution !! 07.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_get(matrix,matrix_struct, distribution,dimensions,& +SUBROUTINE cp_sp_get(matrix,matrix_struct, distribution,dimensions,& sparsity, n_block_rows, n_block_cols, n_rows, n_cols, frozen,& b_rep_is_primary, id_nr, error) - type(cp_block_matrix_type), pointer :: matrix - type(cp_b_matrix_struct_type), pointer, optional :: matrix_struct - type(cp_b_distribution_type), pointer, optional :: distribution - type(cp_b_dims_type), pointer, optional :: dimensions - logical, dimension(:,:), pointer, optional :: sparsity - integer, intent(out), optional :: n_block_cols, n_block_rows,& + TYPE(cp_block_matrix_type), POINTER :: matrix + TYPE(cp_b_matrix_struct_type), POINTER, OPTIONAL :: matrix_struct + TYPE(cp_b_distribution_type), POINTER, OPTIONAL :: distribution + TYPE(cp_b_dims_type), POINTER, OPTIONAL :: dimensions + LOGICAL, DIMENSION(:,:), POINTER, OPTIONAL :: sparsity + INTEGER, INTENT(out), OPTIONAL :: n_block_cols, n_block_rows,& n_rows, n_cols, id_nr - logical, intent(out), optional :: frozen, b_rep_is_primary - type(cp_error_type), optional, intent(inout) :: error + LOGICAL, INTENT(out), OPTIONAL :: frozen, b_rep_is_primary + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_get',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_get',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - CPPrecondition(associated(matrix),cp_failure_level,routineP,error,failure) - if (.not.failure) then + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN CPPrecondition(matrix%ref_count>0,cp_failure_level,routineP,error,failure) - end if - if (.not. failure) then - if (present(matrix_struct)) matrix_struct => matrix%matrix_struct - if (present(distribution)) distribution => & + END IF + IF (.NOT. failure) THEN + IF (PRESENT(matrix_struct)) matrix_struct => matrix%matrix_struct + IF (PRESENT(distribution)) distribution => & matrix%matrix_struct%distribution - if (present(dimensions)) dimensions => matrix%matrix_struct%b_dims - if (present(sparsity)) sparsity => matrix%matrix_struct%sparsity - if (present(n_block_rows)) n_block_rows = & - size(matrix%matrix_struct%b_dims%block_begins_at_row)-1 - if (present(n_block_cols)) n_block_cols = & - size(matrix%matrix_struct%b_dims%block_begins_at_col)-1 - if (present(n_rows)) n_rows = & + IF (PRESENT(dimensions)) dimensions => matrix%matrix_struct%b_dims + IF (PRESENT(sparsity)) sparsity => matrix%matrix_struct%sparsity + IF (PRESENT(n_block_rows)) n_block_rows = & + SIZE(matrix%matrix_struct%b_dims%block_begins_at_row)-1 + IF (PRESENT(n_block_cols)) n_block_cols = & + SIZE(matrix%matrix_struct%b_dims%block_begins_at_col)-1 + IF (PRESENT(n_rows)) n_rows = & matrix%matrix_struct%b_dims%block_begins_at_row & - (size(matrix%matrix_struct%b_dims%block_begins_at_row))-1 - if (present(n_cols)) n_cols = & + (SIZE(matrix%matrix_struct%b_dims%block_begins_at_row))-1 + IF (PRESENT(n_cols)) n_cols = & matrix%matrix_struct%b_dims%block_begins_at_col & - (size(matrix%matrix_struct%b_dims%block_begins_at_col))-1 - if (present(frozen)) frozen=matrix%frozen - if (present(b_rep_is_primary)) b_rep_is_primary=matrix%b_rep_is_primary - if (present(id_nr)) id_nr=matrix%id_nr - end if -end subroutine cp_sp_get + (SIZE(matrix%matrix_struct%b_dims%block_begins_at_col))-1 + IF (PRESENT(frozen)) frozen=matrix%frozen + IF (PRESENT(b_rep_is_primary)) b_rep_is_primary=matrix%b_rep_is_primary + IF (PRESENT(id_nr)) id_nr=matrix%id_nr + END IF +END SUBROUTINE cp_sp_get !*************************************************************************** @@ -1641,22 +1659,22 @@ end subroutine cp_sp_get !! 07.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_redistribute(matrix, new_distribution, error) - type(cp_block_matrix_type), intent(inout), target :: matrix - type(cp_b_distribution_type), pointer :: new_distribution - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_redistribute(matrix, new_distribution, error) + TYPE(cp_block_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_b_distribution_type), POINTER :: new_distribution + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_redistribute',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_redistribute',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - if (.not. failure) then - call cp_unimplemented_error(fromWhere=routineP, & + IF (.NOT. failure) THEN + CALL cp_unimplemented_error(fromWhere=routineP, & message="redistribute", error=error) ! to do - end if -end subroutine cp_sp_redistribute + END IF +END SUBROUTINE cp_sp_redistribute !***************************************************************************\ !!****f* cp_block_matrix/cp_sp_set_to [1.0] * @@ -1690,22 +1708,22 @@ end subroutine cp_sp_redistribute !! 07.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sp_set_to(matrix, value, error) - type(cp_block_matrix_type), pointer :: matrix - real(kind=wp), intent(in), optional :: value - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_sp_set_to(matrix, value, error) + TYPE(cp_block_matrix_type), POINTER :: matrix + REAL(kind=wp), INTENT(in), OPTIONAL :: value + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sp_set_to',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sp_set_to',& routineP=moduleN//':'//routineN - failure=.false. + failure=.FALSE. - CPPrecondition(associated(matrix),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) CPPrecondition(matrix%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - call cp_sm_set_to(matrix%sm, value=value, error=error) - end if -end subroutine cp_sp_set_to + IF (.NOT. failure) THEN + CALL cp_sm_set_to(matrix%sm, value=value, error=error) + END IF +END SUBROUTINE cp_sp_set_to !*************************************************************************** !!****f* cp_block_matrix/cp_sp_multiplies_blacs [1.0] * @@ -1758,19 +1776,19 @@ end subroutine cp_sp_set_to !! 07.2002 created [fawzi] !! !!*** ********************************************************************** - subroutine cp_sp_multiplies_blacs(matrix_a,matrix_b,matrix_c,alpha,beta,error) - type(cp_block_matrix_type), pointer :: matrix_a - type(cp_full_matrix_type), pointer :: matrix_b, matrix_c - real(kind=wp), intent(in), optional :: alpha, beta - type(cp_error_type), intent(inout), optional :: error + SUBROUTINE cp_sp_multiplies_blacs(matrix_a,matrix_b,matrix_c,alpha,beta,error) + TYPE(cp_block_matrix_type), POINTER :: matrix_a + TYPE(cp_full_matrix_type), POINTER :: matrix_b, matrix_c + REAL(kind=wp), INTENT(in), OPTIONAL :: alpha, beta + TYPE(cp_error_type), INTENT(inout), OPTIONAL :: error - integer :: ncol + INTEGER :: ncol - call cp_fm_get_info(matrix_b,ncol_global=ncol) - call cp_sm_fm_multiply(matrix_a%sm, matrix_b, matrix_c,ncol,& + CALL cp_fm_get_info(matrix_b,ncol_global=ncol) + CALL cp_sm_fm_multiply(matrix_a%sm, matrix_b, matrix_c,ncol,& para_env=matrix_a%matrix_struct%distribution%para_env,& alpha=alpha, beta=beta,& block_owner=matrix_a%matrix_struct%distribution%block_owner) - end subroutine cp_sp_multiplies_blacs + END SUBROUTINE cp_sp_multiplies_blacs -end module cp_block_matrix +END MODULE cp_block_matrix diff --git a/src/cp_e_rosenbrok_function.F b/src/cp_e_rosenbrok_function.F index 1fde64eadd..efa357c7f0 100644 --- a/src/cp_e_rosenbrok_function.F +++ b/src/cp_e_rosenbrok_function.F @@ -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 diff --git a/src/cp_error_handling.F b/src/cp_error_handling.F index 1d852d8bdf..7b690f306f 100644 --- a/src/cp_error_handling.F +++ b/src/cp_error_handling.F @@ -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 ! ***************************************************************************** diff --git a/src/cp_fm_basic_linalg.F b/src/cp_fm_basic_linalg.F index 5d63d8e201..75f23c82cc 100644 --- a/src/cp_fm_basic_linalg.F +++ b/src/cp_fm_basic_linalg.F @@ -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 diff --git a/src/cp_fm_cholesky.F b/src/cp_fm_cholesky.F index 46913ea17b..4ae444fc9b 100644 --- a/src/cp_fm_cholesky.F +++ b/src/cp_fm_cholesky.F @@ -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 diff --git a/src/cp_fm_pool_types.F b/src/cp_fm_pool_types.F index 89cc64bc39..9cbe69616a 100644 --- a/src/cp_fm_pool_types.F +++ b/src/cp_fm_pool_types.F @@ -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,& diff --git a/src/cp_fm_struct.F b/src/cp_fm_struct.F index 4f65d05974..847b544742 100644 --- a/src/cp_fm_struct.F +++ b/src/cp_fm_struct.F @@ -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=dp -use machine, only: m_cputime +MODULE cp_lbfgs + USE kinds, ONLY: wp=>dp + USE machine, ONLY: m_cputime +INTEGER, PUBLIC :: cp_lbfgs_unit_nr=6 +CONTAINS -integer, public :: cp_lbfgs_unit_nr=6 -contains - -subroutine setulb (n, m, x, l, u, nbd, f, g, factr, pgtol, wa, & +SUBROUTINE setulb (n, m, x, l, u, nbd, f, g, factr, pgtol, wa, & iwa, task, iprint, csave, lsave, isave, dsave) - character (len=60) :: task, csave - logical :: lsave (4) - integer :: n, m, iprint, nbd (n), iwa (3 * n), isave (44) + CHARACTER (len=60) :: task, csave + LOGICAL :: lsave (4) + INTEGER :: n, m, iprint, nbd (n), iwa (3 * n), isave (44) doubleprecision f, factr, pgtol, x (n), l (n), u (n), g (n), & @@ -201,9 +200,9 @@ subroutine setulb (n, m, x, l, u, nbd, f, g, factr, pgtol, wa, & ! ! ************ - integer :: l1, l2, l3, lws, lr, lz, lt, ld, lwa, lwy, lsy, lss, & + INTEGER :: l1, l2, l3, lws, lr, lz, lt, ld, lwa, lwy, lsy, lss, & lwt, lwn, lsnd - if (task.eq.'START') then + IF (task.eq.'START') THEN isave (1) = m * n isave (2) = m**2 isave (3) = 4 * m**2 @@ -220,7 +219,7 @@ subroutine setulb (n, m, x, l, u, nbd, f, g, factr, pgtol, wa, & isave (14) = isave (13) + n isave (15) = isave (14) + n isave (16) = isave (15) + n - endif + ENDIF l1 = isave (1) l2 = isave (2) l3 = isave (3) @@ -238,24 +237,24 @@ subroutine setulb (n, m, x, l, u, nbd, f, g, factr, pgtol, wa, & lwa = isave (16) - call mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, wa (lws), & + CALL mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, wa (lws), & wa (lwy), wa (lsy), wa (lss), wa (lwt), wa (lwn), wa (lsnd), & wa (lz), wa (lr), wa (ld), wa (lt), wa (lwa), iwa (1), iwa (n + 1) & , iwa (2 * n + 1), task, iprint, csave, lsave, isave (22), & dsave) - return + RETURN -end subroutine setulb +END SUBROUTINE setulb !======================= The end of setulb ============================= -subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & +SUBROUTINE mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & sy, ss, wt, wn, snd, z, r, d, t, wa, index, iwhere, indx2, task, & iprint, csave, lsave, isave, dsave) - character (len=60) :: task, csave - logical :: lsave (4) - integer :: n, m, iprint, nbd (n), index (n), iwhere (n), indx2 (n) & + CHARACTER (len=60) :: task, csave + LOGICAL :: lsave (4) + INTEGER :: n, m, iprint, nbd (n), INDEX (n), iwhere (n), indx2 (n) & , isave (23) @@ -439,9 +438,9 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & ! ! ! ************ - logical :: prjctd, cnstnd, boxed, updatd, wrk - character (len=3) :: word - integer :: i, k, nintol, itfile, iback, nskip, head, col, iter, & + LOGICAL :: prjctd, cnstnd, boxed, updatd, wrk + CHARACTER (len=3) :: word + INTEGER :: i, k, nintol, itfile, iback, nskip, head, col, iter, & itail, iupdat, nint, nfgv, info, ifun, iword, nfree, nact, ileave, & nenter doubleprecision theta, fold, ddot, dr, rr, tol, dpmeps, xstep, & @@ -449,14 +448,14 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & lnscht, time1, time2, gd, gdold, stp, stpmx, time doubleprecision one, zero - parameter (one = 1.0d0, zero = 0.0d0) + PARAMETER (one = 1.0d0, zero = 0.0d0) - if (task.eq.'START') then + IF (task.eq.'START') THEN - call timer (time1) + CALL timer (time1) ! Generate the current machine precision. - epsmch = epsilon(0.0_wp) + epsmch = EPSILON(0.0_wp) fold = 0.0d0 dnorm = 0.0d0 cpu1 = 0.0d0 @@ -475,7 +474,7 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & head = 1 theta = one iupdat = 0 - updatd = .false. + updatd = .FALSE. iback = 0 itail = 0 ifun = 0 @@ -507,33 +506,33 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & info = 0 itfile = 0 - if (iprint.ge.1) then + IF (iprint.ge.1) THEN ! open a summary file 'iterate.dat' - open (8, file = 'iterate.dat', status = 'unknown') + OPEN (8, file = 'iterate.dat', status = 'unknown') itfile = 8 - endif + ENDIF ! Check the input arguments for errors. - call errclb (n, m, factr, l, u, nbd, task, info, k) - if (task (1:5) .eq.'ERROR') then - call prn3lb (n, x, f, task, iprint, info, itfile, iter, & + CALL errclb (n, m, factr, l, u, nbd, task, info, k) + IF (task (1:5) .EQ.'ERROR') THEN + CALL prn3lb (n, x, f, task, iprint, info, itfile, iter, & nfgv, nintol, nskip, nact, sbgnrm, zero, nint, word, iback, & stp, xstep, k, cachyt, sbtime, lnscht) - return + RETURN - endif + ENDIF - call prn1lb (n, m, l, u, x, iprint, itfile, epsmch) + CALL prn1lb (n, m, l, u, x, iprint, itfile, epsmch) ! Initialize iwhere & project x onto the feasible set. - call active (n, l, u, nbd, x, iwhere, iprint, prjctd, cnstnd, & + CALL active (n, l, u, nbd, x, iwhere, iprint, prjctd, cnstnd, & boxed) ! The end of the initialization. - else + ELSE ! restore local variables. prjctd = lsave (1) cnstnd = lsave (2) @@ -579,80 +578,80 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & dtd = dsave (16) ! After returning from the driver go to the point where execution ! is to resume. - if (task (1:5) .eq.'FG_LN') goto 666 - if (task (1:5) .eq.'NEW_X') goto 777 - if (task (1:5) .eq.'FG_ST') goto 111 - if (task (1:4) .eq.'STOP') then - if (task (7:9) .eq.'CPU') then + IF (task (1:5) .EQ.'FG_LN') GOTO 666 + IF (task (1:5) .EQ.'NEW_X') GOTO 777 + IF (task (1:5) .EQ.'FG_ST') GOTO 111 + IF (task (1:4) .EQ.'STOP') THEN + IF (task (7:9) .EQ.'CPU') THEN ! restore the previous iterate. - call dcopy (n, t, 1, x, 1) - call dcopy (n, r, 1, g, 1) + CALL dcopy (n, t, 1, x, 1) + CALL dcopy (n, r, 1, g, 1) f = fold - endif - goto 999 - endif + ENDIF + GOTO 999 + ENDIF - endif + ENDIF ! Compute f0 and g0. task = 'FG_START' ! return to the driver to calculate f and g; reenter at 111. - goto 1000 -111 continue + GOTO 1000 +111 CONTINUE nfgv = 1 ! Compute the infinity norm of the (-) projected gradient. - call projgr (n, l, u, nbd, x, g, sbgnrm) - if (iprint.ge.1) then - write ( cp_lbfgs_unit_nr, 1002) iter, f, sbgnrm - write (itfile, 1003) iter, nfgv, sbgnrm, f - endif - if (sbgnrm.le.pgtol) then + CALL projgr (n, l, u, nbd, x, g, sbgnrm) + IF (iprint.ge.1) THEN + WRITE ( cp_lbfgs_unit_nr, 1002) iter, f, sbgnrm + WRITE (itfile, 1003) iter, nfgv, sbgnrm, f + ENDIF + IF (sbgnrm.le.pgtol) THEN ! terminate the algorithm. task = 'CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL' - goto 999 + GOTO 999 - endif + ENDIF ! ----------------- the beginning of the loop -------------------------- -222 continue - if (iprint.ge.99) write ( cp_lbfgs_unit_nr, 1001) iter + 1 +222 CONTINUE + IF (iprint.ge.99) WRITE ( cp_lbfgs_unit_nr, 1001) iter + 1 iword = - 1 ! - if (.not.cnstnd.and.col.gt.0) then + IF (.not.cnstnd.and.col.gt.0) THEN ! skip the search for GCP. - call dcopy (n, x, 1, z, 1) + CALL dcopy (n, x, 1, z, 1) wrk = updatd nint = 0 - goto 333 + GOTO 333 - endif + ENDIF !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! ! Compute the Generalized Cauchy Point (GCP). ! !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - call timer (cpu1) - call cauchy (n, x, l, u, nbd, g, indx2, iwhere, t, d, z, m, wy, & + CALL timer (cpu1) + CALL cauchy (n, x, l, u, nbd, g, indx2, iwhere, t, d, z, m, wy, & ws, sy, wt, theta, col, head, wa (1), wa (2 * m + 1), wa (4 * m + & 1), wa (6 * m + 1), nint, iprint, sbgnrm, info, epsmch) - if (info.ne.0) then + IF (info.ne.0) THEN ! singular triangular system detected; refresh the lbfgs memory. - if (iprint.ge.1) write ( cp_lbfgs_unit_nr, 1005) + IF (iprint.ge.1) WRITE ( cp_lbfgs_unit_nr, 1005) info = 0 col = 0 head = 1 theta = one iupdat = 0 - updatd = .false. - call timer (cpu2) + updatd = .FALSE. + CALL timer (cpu2) cachyt = cachyt + cpu2 - cpu1 - goto 222 - endif - call timer (cpu2) + GOTO 222 + ENDIF + CALL timer (cpu2) cachyt = cachyt + cpu2 - cpu1 @@ -660,18 +659,18 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & ! Count the entering and leaving variables for iter > 0; ! find the index set of free and active variables at the GCP. - call freev (n, nfree, index, nenter, ileave, indx2, iwhere, wrk, & + CALL freev (n, nfree, index, nenter, ileave, indx2, iwhere, wrk, & updatd, cnstnd, iprint, iter) nact = n - nfree -333 continue +333 CONTINUE ! If there are no free variables or B=theta*I, then ! skip the subspace minimization. - if (nfree.eq.0.or.col.eq.0) goto 555 + IF (nfree.eq.0.or.col.eq.0) GOTO 555 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! ! Subspace minimization. @@ -679,111 +678,111 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - call timer (cpu1) + CALL timer (cpu1) ! Form the LEL^T factorization of the indefinite ! matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] ! [L_a -R_z theta*S'AA'S ] ! where E = [-I 0] ! [ 0 I] - if (wrk) call formk (n, nfree, index, nenter, ileave, indx2, & + IF (wrk) CALL formk (n, nfree, index, nenter, ileave, indx2, & iupdat, updatd, wn, snd, m, ws, wy, sy, theta, col, head, info) - if (info.ne.0) then + IF (info.ne.0) THEN ! nonpositive definiteness in Cholesky factorization; ! refresh the lbfgs memory and restart the iteration. - if (iprint.ge.1) write ( cp_lbfgs_unit_nr, 1006) + IF (iprint.ge.1) WRITE ( cp_lbfgs_unit_nr, 1006) info = 0 col = 0 head = 1 theta = one iupdat = 0 - updatd = .false. - call timer (cpu2) + updatd = .FALSE. + CALL timer (cpu2) sbtime = sbtime+cpu2 - cpu1 - goto 222 + GOTO 222 - endif + ENDIF ! compute r=-Z'B(xcp-xk)-Z'g (using wa(2m+1)=W'(xcp-x) ' ! from 'cauchy'). - call cmprlb (n, m, x, g, ws, wy, sy, wt, z, r, wa, index, theta, & + CALL cmprlb (n, m, x, g, ws, wy, sy, wt, z, r, wa, index, theta, & col, head, nfree, cnstnd, info) - if (info.ne.0) goto 444 + IF (info.ne.0) GOTO 444 ! call the direct method. - call subsm (n, m, nfree, index, l, u, nbd, z, r, ws, wy, theta, & + CALL subsm (n, m, nfree, index, l, u, nbd, z, r, ws, wy, theta, & col, head, iword, wa, wn, iprint, info) -444 continue - if (info.ne.0) then +444 CONTINUE + IF (info.ne.0) THEN ! singular triangular system detected; ! refresh the lbfgs memory and restart the iteration. - if (iprint.ge.1) write ( cp_lbfgs_unit_nr, 1005) + IF (iprint.ge.1) WRITE ( cp_lbfgs_unit_nr, 1005) info = 0 col = 0 head = 1 theta = one iupdat = 0 - updatd = .false. - call timer (cpu2) + updatd = .FALSE. + CALL timer (cpu2) sbtime = sbtime+cpu2 - cpu1 - goto 222 + GOTO 222 - endif - call timer (cpu2) + ENDIF + CALL timer (cpu2) sbtime = sbtime+cpu2 - cpu1 -555 continue +555 CONTINUE !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! ! Line search and optimality tests. ! !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! Generate the search direction d:=z-x. - do 40 i = 1, n + DO 40 i = 1, n d (i) = z (i) - x (i) -40 end do - call timer (cpu1) -666 continue - call lnsrlb (n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, t, z, & +40 END DO + CALL timer (cpu1) +666 CONTINUE + CALL lnsrlb (n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, t, z, & stp, dnorm, dtd, xstep, stpmx, iter, ifun, iback, nfgv, info, & task, boxed, cnstnd, csave, isave (22), dsave (17) ) - if (info.ne.0.or.iback.ge.20) then + IF (info.ne.0.or.iback.ge.20) THEN ! restore the previous iterate. - call dcopy (n, t, 1, x, 1) - call dcopy (n, r, 1, g, 1) + CALL dcopy (n, t, 1, x, 1) + CALL dcopy (n, r, 1, g, 1) f = fold - if (col.eq.0) then + IF (col.eq.0) THEN ! abnormal termination. - if (info.eq.0) then + IF (info.eq.0) THEN info = - 9 ! restore the actual number of f and g evaluations etc. nfgv = nfgv - 1 ifun = ifun - 1 iback = iback - 1 - endif + ENDIF task = 'ABNORMAL_TERMINATION_IN_LNSRCH' iter = iter + 1 - goto 999 - else + GOTO 999 + ELSE ! refresh the lbfgs memory and restart the iteration. - if (iprint.ge.1) write ( cp_lbfgs_unit_nr, 1008) - if (info.eq.0) nfgv = nfgv - 1 + IF (iprint.ge.1) WRITE ( cp_lbfgs_unit_nr, 1008) + IF (info.eq.0) nfgv = nfgv - 1 info = 0 col = 0 head = 1 theta = one iupdat = 0 - updatd = .false. + updatd = .FALSE. task = 'RESTART_FROM_LNSRCH' - call timer (cpu2) + CALL timer (cpu2) lnscht = lnscht + cpu2 - cpu1 - goto 222 - endif - elseif (task (1:5) .eq.'FG_LN') then + GOTO 222 + ENDIF + ELSEIF (task (1:5) .EQ.'FG_LN') THEN ! return to the driver for calculating f and g; reenter at 666. - goto 1000 - else + GOTO 1000 + ELSE ! calculate and print out the quantities related to the new X. - call timer (cpu2) + CALL timer (cpu2) lnscht = lnscht + cpu2 - cpu1 @@ -791,113 +790,113 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & ! Compute the infinity norm of the projected (-)gradient. - call projgr (n, l, u, nbd, x, g, sbgnrm) + CALL projgr (n, l, u, nbd, x, g, sbgnrm) ! Print iteration information. - call prn2lb (n, x, f, g, iprint, itfile, iter, nfgv, nact, & + CALL prn2lb (n, x, f, g, iprint, itfile, iter, nfgv, nact, & sbgnrm, nint, word, iword, iback, stp, xstep) - goto 1000 - endif + GOTO 1000 + ENDIF -777 continue +777 CONTINUE ! Test for termination. - if (sbgnrm.le.pgtol) then + IF (sbgnrm.le.pgtol) THEN ! terminate the algorithm. task = 'CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL' - goto 999 + GOTO 999 - endif - ddum = max (abs (fold), abs (f), one) - if ( (fold-f) .le.tol * ddum) then - if ( abs (fold-f) .le.tol * ddum) then ! added [fawzi] + ENDIF + ddum = MAX (ABS (fold), ABS (f), one) + IF ( (fold-f) .le.tol * ddum) THEN + IF ( ABS (fold-f) .le.tol * ddum) THEN ! added [fawzi] ! terminate the algorithm. task = 'CONVERGENCE: REL_REDUCTION_OF_F <= FACTR*EPSMCH' - if(iback.ge.10) info = - 5 + IF(iback.ge.10) info = - 5 ! i.e., to issue a warning if iback>10 in the line search. - goto 999 - else + GOTO 999 + ELSE !!FM task = 'RESTART: F>F_OLD' !!FM if(iback.ge.10) info = - 5 !!FM ! i.e., to issue a warning if iback>10 in the line search. !!FM goto 999 - end if + END IF - endif + ENDIF ! Compute d=newx-oldx, r=newg-oldg, rr=y'y and dr=y's. - do 42 i = 1, n + DO 42 i = 1, n r (i) = g (i) - r (i) -42 end do +42 END DO rr = ddot (n, r, 1, r, 1) - if (stp.eq.one) then + IF (stp.eq.one) THEN dr = gd-gdold ddum = - gdold - else + ELSE dr = (gd-gdold) * stp - call dscal (n, stp, d, 1) + CALL dscal (n, stp, d, 1) ddum = - gdold * stp - endif - if (dr.le.epsmch * ddum) then + ENDIF + IF (dr.le.epsmch * ddum) THEN ! skip the L-BFGS update. nskip = nskip + 1 - updatd = .false. - if (iprint.ge.1) write ( cp_lbfgs_unit_nr, 1004) dr, ddum - goto 888 + updatd = .FALSE. + IF (iprint.ge.1) WRITE ( cp_lbfgs_unit_nr, 1004) dr, ddum + GOTO 888 - endif + ENDIF !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! ! Update the L-BFGS matrix. ! !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - updatd = .true. + updatd = .TRUE. iupdat = iupdat + 1 ! Update matrices WS and WY and form the middle matrix in B. - call matupd (n, m, ws, wy, sy, ss, d, r, itail, iupdat, col, head, & + CALL matupd (n, m, ws, wy, sy, ss, d, r, itail, iupdat, col, head, & theta, rr, dr, stp, dtd) ! Form the upper half of the pds T = theta*SS + L*D^(-1)*L'; ' ! Store T in the upper triangular of the array wt; ! Cholesky factorize T to J*J' with ' ! J' stored in the upper triangular of wt. ' - call formt (m, wt, sy, ss, col, theta, info) - if (info.ne.0) then + CALL formt (m, wt, sy, ss, col, theta, info) + IF (info.ne.0) THEN ! nonpositive definiteness in Cholesky factorization; ! refresh the lbfgs memory and restart the iteration. - if (iprint.ge.1) write ( cp_lbfgs_unit_nr, 1007) + IF (iprint.ge.1) WRITE ( cp_lbfgs_unit_nr, 1007) info = 0 col = 0 head = 1 theta = one iupdat = 0 - updatd = .false. - goto 222 + updatd = .FALSE. + GOTO 222 - endif + ENDIF ! Now the inverse of the middle matrix in B is ! [ D^(1/2) O ] [ -D^(1/2) D^(-1/2)*L' ] ' ! [ -L*D^(-1/2) J ] [ 0 J' ] ' -888 continue +888 CONTINUE ! -------------------- the end of the loop ----------------------------- - goto 222 -999 continue - call timer (time2) + GOTO 222 +999 CONTINUE + CALL timer (time2) time = time2 - time1 - call prn3lb (n, x, f, task, iprint, info, itfile, iter, nfgv, & + CALL prn3lb (n, x, f, task, iprint, info, itfile, iter, nfgv, & nintol, nskip, nact, sbgnrm, time, nint, word, iback, stp, xstep, & k, cachyt, sbtime, lnscht) -1000 continue +1000 CONTINUE ! Save local variables. lsave (1) = prjctd lsave (2) = cnstnd @@ -940,36 +939,36 @@ subroutine mainlb (n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, & dsave (15) = gdold dsave (16) = dtd -1001 format (//,'ITERATION ',i5) -1002 format & +1001 FORMAT (//,'ITERATION ',i5) +1002 FORMAT & & (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) -1003 format (2(1x,i4),5x,'-',5x,'-',3x,'-',5x,'-',5x,'-',8x,'-',3x, & +1003 FORMAT (2(1x,i4),5x,'-',5x,'-',3x,'-',5x,'-',5x,'-',8x,'-',3x, & & 1p,2(1x,d10.3)) -1004 format (' ys=',1p,e10.3,' -gs=',1p,e10.3,' BFGS update SKIPPED') -1005 format (/, & +1004 FORMAT (' ys=',1p,e10.3,' -gs=',1p,e10.3,' BFGS update SKIPPED') +1005 FORMAT (/, & &' Singular triangular system detected;',/, & &' refresh the lbfgs memory and restart the iteration.') -1006 format (/, & +1006 FORMAT (/, & &' Nonpositive definiteness in Cholesky factorization in formk;',/, & &' refresh the lbfgs memory and restart the iteration.') -1007 format (/, & +1007 FORMAT (/, & &' Nonpositive definiteness in Cholesky factorization in formt;',/, & &' refresh the lbfgs memory and restart the iteration.') -1008 format (/, & +1008 FORMAT (/, & &' Bad direction in the line search;',/, & &' refresh the lbfgs memory and restart the iteration.') - return + RETURN -end subroutine mainlb +END SUBROUTINE mainlb !======================= The end of mainlb ============================= -subroutine active (n, l, u, nbd, x, iwhere, iprint, prjctd, & +SUBROUTINE active (n, l, u, nbd, x, iwhere, iprint, prjctd, & cnstnd, boxed) - logical :: prjctd, cnstnd, boxed - integer :: n, iprint, nbd (n), iwhere (n) + LOGICAL :: prjctd, cnstnd, boxed + INTEGER :: n, iprint, nbd (n), iwhere (n) doubleprecision x (n), l (n), u (n) @@ -999,76 +998,76 @@ subroutine active (n, l, u, nbd, x, iwhere, iprint, prjctd, & ! ! ! ************ - integer :: nbdd, i + INTEGER :: nbdd, i doubleprecision zero - parameter (zero = 0.0d0) + PARAMETER (zero = 0.0d0) ! Initialize nbdd, prjctd, cnstnd and boxed. nbdd = 0 - prjctd = .false. - cnstnd = .false. + prjctd = .FALSE. + cnstnd = .FALSE. - boxed = .true. + boxed = .TRUE. ! Project the initial x to the easible set if necessary. - do 10 i = 1, n - if (nbd (i) .gt.0) then - if (nbd (i) .le.2.and.x (i) .le.l (i) ) then - if (x (i) .lt.l (i) ) then - prjctd = .true. + DO 10 i = 1, n + IF (nbd (i) .gt.0) THEN + IF (nbd (i) .le.2.and.x (i) .le.l (i) ) THEN + IF (x (i) .lt.l (i) ) THEN + prjctd = .TRUE. x (i) = l (i) - endif + ENDIF nbdd = nbdd+1 - elseif (nbd (i) .ge.2.and.x (i) .ge.u (i) ) then - if (x (i) .gt.u (i) ) then - prjctd = .true. + ELSEIF (nbd (i) .ge.2.and.x (i) .ge.u (i) ) THEN + IF (x (i) .gt.u (i) ) THEN + prjctd = .TRUE. x (i) = u (i) - endif + ENDIF nbdd = nbdd+1 - endif - endif + ENDIF + ENDIF -10 end do +10 END DO ! Initialize iwhere and assign values to cnstnd and boxed. - do 20 i = 1, n - if (nbd (i) .ne.2) boxed = .false. - if (nbd (i) .eq.0) then + DO 20 i = 1, n + IF (nbd (i) .ne.2) boxed = .FALSE. + IF (nbd (i) .eq.0) THEN ! this variable is always free iwhere (i) = - 1 ! otherwise set x(i)=mid(x(i), u(i), l(i)). - else - cnstnd = .true. - if (nbd (i) .eq.2.and.u (i) - l (i) .le.zero) then + ELSE + cnstnd = .TRUE. + IF (nbd (i) .eq.2.and.u (i) - l (i) .le.zero) THEN ! this variable is always fixed iwhere (i) = 3 - else + ELSE iwhere (i) = 0 - endif - endif + ENDIF + ENDIF -20 end do - if (iprint.ge.0) then - if (prjctd) write ( cp_lbfgs_unit_nr, * ) & +20 END DO + IF (iprint.ge.0) THEN + IF (prjctd) WRITE ( cp_lbfgs_unit_nr, * ) & 'The initial X is infeasible. Restart with its projection.' - if (.not.cnstnd) write ( cp_lbfgs_unit_nr, * ) 'This problem is unconstrained.' + IF (.not.cnstnd) WRITE ( cp_lbfgs_unit_nr, * ) 'This problem is unconstrained.' - endif + ENDIF - if (iprint.gt.0) write ( cp_lbfgs_unit_nr, 1001) nbdd + IF (iprint.gt.0) WRITE ( cp_lbfgs_unit_nr, 1001) nbdd -1001 format (/,'At X0 ',i9,' variables are exactly at the bounds') +1001 FORMAT (/,'At X0 ',i9,' variables are exactly at the bounds') - return + RETURN -end subroutine active +END SUBROUTINE active !======================= The end of active ============================= -subroutine bmv (m, sy, wt, col, v, p, info) - integer :: m, col, info +SUBROUTINE bmv (m, sy, wt, col, v, p, info) + INTEGER :: m, col, info doubleprecision sy (m, m), wt (m, m), v (2 * col), p (2 * col) @@ -1129,64 +1128,64 @@ subroutine bmv (m, sy, wt, col, v, p, info) ! ! ! ************ - integer :: i, k, i2 + INTEGER :: i, k, i2 doubleprecision sum - if (col.eq.0) return + IF (col.eq.0) RETURN ! PART I: solve [ D^(1/2) O ] [ p1 ] = [ v1 ] ! [ -L*D^(-1/2) J ] [ p2 ] [ v2 ]. ! solve Jp2=v2+LD^(-1)v1. p (col + 1) = v (col + 1) - do 20 i = 2, col + DO 20 i = 2, col i2 = col + i sum = 0.0d0 - do 10 k = 1, i - 1 + DO 10 k = 1, i - 1 sum = sum + sy (i, k) * v (k) / sy (k, k) -10 end do +10 END DO p (i2) = v (i2) + sum -20 end do +20 END DO ! Solve the triangular system - call dtrsl (wt, m, col, p (col + 1), 11, info) + CALL dtrsl (wt, m, col, p (col + 1), 11, info) - if (info.ne.0) return + IF (info.ne.0) RETURN ! solve D^(1/2)p1=v1. - do 30 i = 1, col - p (i) = v (i) / sqrt (sy (i, i) ) + DO 30 i = 1, col + p (i) = v (i) / SQRT (sy (i, i) ) -30 end do +30 END DO ! PART II: solve [ -D^(1/2) D^(-1/2)*L' ] [ p1 ] = [ p1 ] ' ! [ 0 J' ] [ p2 ] [ p2 ]. ' ! solve J^Tp2=p2. - call dtrsl (wt, m, col, p (col + 1), 01, info) + CALL dtrsl (wt, m, col, p (col + 1), 01, info) - if (info.ne.0) return + IF (info.ne.0) RETURN ! compute p1=-D^(-1/2)(p1-D^(-1/2)L'p2) ' ! =-D^(-1/2)p1+D^(-1)L'p2. ' - do 40 i = 1, col - p (i) = - p (i) / sqrt (sy (i, i) ) -40 end do - do 60 i = 1, col + DO 40 i = 1, col + p (i) = - p (i) / SQRT (sy (i, i) ) +40 END DO + DO 60 i = 1, col sum = 0.d0 - do 50 k = i + 1, col + DO 50 k = i + 1, col sum = sum + sy (k, i) * p (col + k) / sy (i, i) -50 end do +50 END DO p (i) = p (i) + sum -60 end do +60 END DO - return + RETURN -end subroutine bmv +END SUBROUTINE bmv !======================== The end of bmv =============================== -subroutine cauchy (n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, & +SUBROUTINE cauchy (n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, & m, wy, ws, sy, wt, theta, col, head, p, c, wbp, v, nint, iprint, & sbgnrm, info, epsmch) - integer :: n, m, head, col, nint, iprint, info, nbd (n), iorder ( & + INTEGER :: n, m, head, col, nint, iprint, info, nbd (n), iorder ( & n), iwhere (n) @@ -1365,24 +1364,24 @@ subroutine cauchy (n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, & ! ! ! ************ - logical :: xlower, xupper, bnded - integer :: i, j, col2, nfree, nbreak, pointr, ibp, nleft, ibkmin, & + LOGICAL :: xlower, xupper, bnded + INTEGER :: i, j, col2, nfree, nbreak, pointr, ibp, nleft, ibkmin, & iter doubleprecision f1, f2, dt, dtm, tsum, dibp, zibp, dibp2, bkmin, & tu, tl, wmc, wmp, wmw, ddot, tj, tj0, neggi, sbgnrm, f2_org doubleprecision one, zero - parameter (one = 1.0d0, zero = 0.0d0) + PARAMETER (one = 1.0d0, zero = 0.0d0) ! Check the status of the variables, reset iwhere(i) if necessary; ! compute the Cauchy direction d and the breakpoints t; initialize ! the derivative f1 and the vector p = W'd (for theta = 1). ' - if (sbgnrm.le.zero) then - if (iprint.ge.0) write ( cp_lbfgs_unit_nr, * ) 'Subgnorm = 0. GCP = X.' - call dcopy (n, x, 1, xcp, 1) - return - endif - bnded = .true. + IF (sbgnrm.le.zero) THEN + IF (iprint.ge.0) WRITE ( cp_lbfgs_unit_nr, * ) 'Subgnorm = 0. GCP = X.' + CALL dcopy (n, x, 1, xcp, 1) + RETURN + ENDIF + bnded = .TRUE. nfree = n + 1 nbreak = 0 ibkmin = 0 @@ -1391,24 +1390,24 @@ subroutine cauchy (n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, & f1 = zero - if (iprint.ge.99) write ( cp_lbfgs_unit_nr, 3010) + IF (iprint.ge.99) WRITE ( cp_lbfgs_unit_nr, 3010) ! We set p to zero and build it up as we determine d. - do 20 i = 1, col2 + DO 20 i = 1, col2 p (i) = zero -20 end do +20 END DO ! In the following loop we determine for each variable its bound ! status and its breakpoint, and update p accordingly. ! Smallest breakpoint is identified. - do 50 i = 1, n + DO 50 i = 1, n neggi = - g (i) - if (iwhere (i) .ne.3.and.iwhere (i) .ne. - 1) then + IF (iwhere (i) .ne.3.and.iwhere (i) .NE. - 1) THEN ! if x(i) is not a constant and has bounds, ! compute the difference between x(i) and its bounds. - if (nbd (i) .le.2) tl = x (i) - l (i) + IF (nbd (i) .le.2) tl = x (i) - l (i) - if (nbd (i) .ge.2) tu = u (i) - x (i) + IF (nbd (i) .ge.2) tu = u (i) - x (i) ! If a variable is close enough to a bound ! we treat it as at bound. xlower = nbd (i) .le.2.and.tl.le.zero @@ -1416,97 +1415,97 @@ subroutine cauchy (n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, & xupper = nbd (i) .ge.2.and.tu.le.zero ! reset iwhere(i). iwhere (i) = 0 - if (xlower) then - if (neggi.le.zero) iwhere (i) = 1 - elseif (xupper) then - if (neggi.ge.zero) iwhere (i) = 2 - else - if (abs (neggi) .le.zero) iwhere (i) = - 3 - endif - endif + IF (xlower) THEN + IF (neggi.le.zero) iwhere (i) = 1 + ELSEIF (xupper) THEN + IF (neggi.ge.zero) iwhere (i) = 2 + ELSE + IF (ABS (neggi) .le.zero) iwhere (i) = - 3 + ENDIF + ENDIF pointr = head - if (iwhere (i) .ne.0.and.iwhere (i) .ne. - 1) then + IF (iwhere (i) .ne.0.and.iwhere (i) .NE. - 1) THEN d (i) = zero - else + ELSE d (i) = neggi f1 = f1 - neggi * neggi ! calculate p := p - W'e_i* (g_i). ' - do 40 j = 1, col + DO 40 j = 1, col p (j) = p (j) + wy (i, pointr) * neggi p (col + j) = p (col + j) + ws (i, pointr) * neggi - pointr = mod (pointr, m) + 1 -40 end do - if (nbd (i) .le.2.and.nbd (i) .ne.0.and.neggi.lt.zero) then + pointr = MOD (pointr, m) + 1 +40 END DO + IF (nbd (i) .le.2.and.nbd (i) .ne.0.and.neggi.lt.zero) THEN ! x(i) + d(i) is bounded; compute t(i). nbreak = nbreak + 1 iorder (nbreak) = i t (nbreak) = tl / ( - neggi) - if (nbreak.eq.1.or.t (nbreak) .lt.bkmin) then + IF (nbreak.eq.1.or.t (nbreak) .lt.bkmin) THEN bkmin = t (nbreak) ibkmin = nbreak - endif - elseif (nbd (i) .ge.2.and.neggi.gt.zero) then + ENDIF + ELSEIF (nbd (i) .ge.2.and.neggi.gt.zero) THEN ! x(i) + d(i) is bounded; compute t(i). nbreak = nbreak + 1 iorder (nbreak) = i t (nbreak) = tu / neggi - if (nbreak.eq.1.or.t (nbreak) .lt.bkmin) then + IF (nbreak.eq.1.or.t (nbreak) .lt.bkmin) THEN bkmin = t (nbreak) ibkmin = nbreak - endif - else + ENDIF + ELSE ! x(i) + d(i) is not bounded. nfree = nfree-1 iorder (nfree) = i - if (abs (neggi) .gt.zero) bnded = .false. - endif - endif + IF (ABS (neggi) .gt.zero) bnded = .FALSE. + ENDIF + ENDIF -50 end do +50 END DO ! The indices of the nonzero components of d are now stored ! in iorder(1),...,iorder(nbreak) and iorder(nfree),...,iorder(n). ! The smallest of the nbreak breakpoints is in t(ibkmin)=bkmin. - if (theta.ne.one) then + IF (theta.ne.one) THEN ! complete the initialization of p for theta not= one. - call dscal (col, theta, p (col + 1), 1) + CALL dscal (col, theta, p (col + 1), 1) - endif + ENDIF ! Initialize GCP xcp = x. - call dcopy (n, x, 1, xcp, 1) - if (nbreak.eq.0.and.nfree.eq.n + 1) then + CALL dcopy (n, x, 1, xcp, 1) + IF (nbreak.eq.0.and.nfree.eq.n + 1) THEN ! is a zero vector, return with the initial xcp as GCP. - if (iprint.gt.100) write ( cp_lbfgs_unit_nr, 1010) (xcp (i), i = 1, n) - return + IF (iprint.gt.100) WRITE ( cp_lbfgs_unit_nr, 1010) (xcp (i), i = 1, n) + RETURN - endif + ENDIF ! Initialize c = W'(xcp - x) = 0. ' - do 60 j = 1, col2 + DO 60 j = 1, col2 c (j) = zero -60 end do +60 END DO ! Initialize derivative f2. f2 = - theta * f1 f2_org = f2 - if (col.gt.0) then - call bmv (m, sy, wt, col, p, v, info) - if (info.ne.0) return + IF (col.gt.0) THEN + CALL bmv (m, sy, wt, col, p, v, info) + IF (info.ne.0) RETURN f2 = f2 - ddot (col2, v, 1, p, 1) - endif + ENDIF dtm = - f1 / f2 tsum = zero nint = 1 - if (iprint.ge.99) write ( cp_lbfgs_unit_nr, * ) 'There are ', nbreak, & + IF (iprint.ge.99) WRITE ( cp_lbfgs_unit_nr, * ) 'There are ', nbreak, & ' breakpoints ' ! If there are no breakpoints, locate the GCP and return. - if (nbreak.eq.0) goto 888 + IF (nbreak.eq.0) GOTO 888 nleft = nbreak @@ -1517,46 +1516,46 @@ subroutine cauchy (n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, & !------------------- the beginning of the loop ------------------------- -777 continue +777 CONTINUE ! Find the next smallest breakpoint; ! compute dt = t(nleft) - t(nleft + 1). tj0 = tj - if (iter.eq.1) then + IF (iter.eq.1) THEN ! Since we already have the smallest breakpoint we need not do ! heapsort yet. Often only one breakpoint is used and the ! cost of heapsort is avoided. tj = bkmin ibp = iorder (ibkmin) - else - if (iter.eq.2) then + ELSE + IF (iter.eq.2) THEN ! Replace the already used smallest breakpoint with the ! breakpoint numbered nbreak > nlast, before heapsort call. - if (ibkmin.ne.nbreak) then + IF (ibkmin.ne.nbreak) THEN t (ibkmin) = t (nbreak) iorder (ibkmin) = iorder (nbreak) - endif + ENDIF ! Update heap structure of breakpoints ! (if iter=2, initialize heap). - endif - call hpsolb (nleft, t, iorder, iter - 2) + ENDIF + CALL hpsolb (nleft, t, iorder, iter - 2) tj = t (nleft) ibp = iorder (nleft) - endif + ENDIF dt = tj - tj0 - if (dt.ne.zero.and.iprint.ge.100) then - write ( cp_lbfgs_unit_nr, 4011) nint, f1, f2 - write ( cp_lbfgs_unit_nr, 5010) dt - write ( cp_lbfgs_unit_nr, 6010) dtm + IF (dt.ne.zero.and.iprint.ge.100) THEN + WRITE ( cp_lbfgs_unit_nr, 4011) nint, f1, f2 + WRITE ( cp_lbfgs_unit_nr, 5010) dt + WRITE ( cp_lbfgs_unit_nr, 6010) dtm - endif + ENDIF ! If a minimizer is within this interval, ! locate the GCP and return. - if (dtm.lt.dt) goto 888 + IF (dtm.lt.dt) GOTO 888 ! Otherwise fix one variable and ! reset the corresponding component of d to zero. tsum = tsum + dt @@ -1564,24 +1563,24 @@ subroutine cauchy (n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, & iter = iter + 1 dibp = d (ibp) d (ibp) = zero - if (dibp.gt.zero) then + IF (dibp.gt.zero) THEN zibp = u (ibp) - x (ibp) xcp (ibp) = u (ibp) iwhere (ibp) = 2 - else + ELSE zibp = l (ibp) - x (ibp) xcp (ibp) = l (ibp) iwhere (ibp) = 1 - endif - if (iprint.ge.100) write ( cp_lbfgs_unit_nr, * ) 'Variable ', ibp, ' is fixed.' - if (nleft.eq.0.and.nbreak.eq.n) then + ENDIF + IF (iprint.ge.100) WRITE ( cp_lbfgs_unit_nr, * ) 'Variable ', ibp, ' is fixed.' + IF (nleft.eq.0.and.nbreak.eq.n) THEN ! all n variables are fixed, ! return with xcp as GCP. dtm = dt - goto 999 + GOTO 999 - endif + ENDIF ! Update the derivative information. nint = nint + 1 @@ -1592,93 +1591,93 @@ subroutine cauchy (n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, & f1 = f1 + dt * f2 + dibp2 - theta * dibp * zibp f2 = f2 - theta * dibp2 - if (col.gt.0) then + IF (col.gt.0) THEN ! update c = c + dt*p. - call daxpy (col2, dt, p, 1, c, 1) + CALL daxpy (col2, dt, p, 1, c, 1) ! choose wbp, ! the row of W corresponding to the breakpoint encountered. pointr = head - do 70 j = 1, col + DO 70 j = 1, col wbp (j) = wy (ibp, pointr) wbp (col + j) = theta * ws (ibp, pointr) - pointr = mod (pointr, m) + 1 + pointr = MOD (pointr, m) + 1 -70 end do +70 END DO ! compute (wbp)Mc, (wbp)Mp, and (wbp)M(wbp)'. ' - call bmv (m, sy, wt, col, wbp, v, info) - if (info.ne.0) return + CALL bmv (m, sy, wt, col, wbp, v, info) + IF (info.ne.0) RETURN wmc = ddot (col2, c, 1, v, 1) wmp = ddot (col2, p, 1, v, 1) wmw = ddot (col2, wbp, 1, v, 1) ! update p = p - dibp*wbp. - call daxpy (col2, - dibp, wbp, 1, p, 1) + CALL daxpy (col2, - dibp, wbp, 1, p, 1) ! complete updating f1 and f2 while col > 0. f1 = f1 + dibp * wmc f2 = f2 + 2.0d0 * dibp * wmp - dibp2 * wmw - endif - f2 = max (epsmch * f2_org, f2) - if (nleft.gt.0) then + ENDIF + f2 = MAX (epsmch * f2_org, f2) + IF (nleft.gt.0) THEN dtm = - f1 / f2 - goto 777 + GOTO 777 ! to repeat the loop for unsearched intervals. - elseif (bnded) then + ELSEIF (bnded) THEN f1 = zero f2 = zero dtm = zero - else + ELSE dtm = - f1 / f2 - endif + ENDIF !------------------- the end of the loop ------------------------------- -888 continue - if (iprint.ge.99) then - write ( cp_lbfgs_unit_nr, * ) - write ( cp_lbfgs_unit_nr, * ) 'GCP found in this segment' - write ( cp_lbfgs_unit_nr, 4010) nint, f1, f2 - write ( cp_lbfgs_unit_nr, 6010) dtm - endif - if (dtm.le.zero) dtm = zero +888 CONTINUE + IF (iprint.ge.99) THEN + WRITE ( cp_lbfgs_unit_nr, * ) + WRITE ( cp_lbfgs_unit_nr, * ) 'GCP found in this segment' + WRITE ( cp_lbfgs_unit_nr, 4010) nint, f1, f2 + WRITE ( cp_lbfgs_unit_nr, 6010) dtm + ENDIF + IF (dtm.le.zero) dtm = zero tsum = tsum + dtm ! Move free variables (i.e., the ones w/o breakpoints) and ! the variables whose breakpoints have not been reached. - call daxpy (n, tsum, d, 1, xcp, 1) + CALL daxpy (n, tsum, d, 1, xcp, 1) -999 continue +999 CONTINUE ! Update c = c + dtm*p = W'(x^c - x) ' ! which will be used in computing r = Z'(B(x^c - x) + g). ' - if (col.gt.0) call daxpy (col2, dtm, p, 1, c, 1) - if (iprint.gt.100) write ( cp_lbfgs_unit_nr, 1010) (xcp (i), i = 1, n) + IF (col.gt.0) CALL daxpy (col2, dtm, p, 1, c, 1) + IF (iprint.gt.100) WRITE ( cp_lbfgs_unit_nr, 1010) (xcp (i), i = 1, n) - if (iprint.ge.99) write ( cp_lbfgs_unit_nr, 2010) -1010 format ('Cauchy X = ',/,(4x,1p,6(1x,d11.4))) -2010 format (/,'---------------- exit CAUCHY----------------------',/) -3010 format (/,'---------------- CAUCHY entered-------------------') -4010 format ('Piece ',i3,' --f1, f2 at start point ',1p,2(1x,d11.4)) -4011 format (/,'Piece ',i3,' --f1, f2 at start point ', & + IF (iprint.ge.99) WRITE ( cp_lbfgs_unit_nr, 2010) +1010 FORMAT ('Cauchy X = ',/,(4x,1p,6(1x,d11.4))) +2010 FORMAT (/,'---------------- EXIT CAUCHY----------------------',/) +3010 FORMAT (/,'---------------- CAUCHY entered-------------------') +4010 FORMAT ('Piece ',i3,' --f1, f2 at start point ',1p,2(1x,d11.4)) +4011 FORMAT (/,'Piece ',i3,' --f1, f2 at start point ', & & 1p,2(1x,d11.4)) -5010 format ('Distance to the next break point = ',1p,d11.4) +5010 FORMAT ('Distance to the next break point = ',1p,d11.4) -6010 format ('Distance to the stationary point = ',1p,d11.4) +6010 FORMAT ('Distance to the stationary point = ',1p,d11.4) - return + RETURN -end subroutine cauchy +END SUBROUTINE cauchy !====================== The end of cauchy ============================== -subroutine cmprlb (n, m, x, g, ws, wy, sy, wt, z, r, wa, index, & +SUBROUTINE cmprlb (n, m, x, g, ws, wy, sy, wt, z, r, wa, index, & theta, col, head, nfree, cnstnd, info) - logical :: cnstnd - integer :: n, m, col, head, nfree, info, index (n) + LOGICAL :: cnstnd + INTEGER :: n, m, col, head, nfree, info, INDEX (n) doubleprecision theta, x (n), g (n), z (n), r (n), wa (4 * m), & @@ -1706,46 +1705,46 @@ subroutine cmprlb (n, m, x, g, ws, wy, sy, wt, z, r, wa, index, & ! ! ! ************ - integer :: i, j, k, pointr + INTEGER :: i, j, k, pointr doubleprecision a1, a2 - if (.not.cnstnd.and.col.gt.0) then - do 26 i = 1, n + IF (.not.cnstnd.and.col.gt.0) THEN + DO 26 i = 1, n r (i) = - g (i) -26 end do - else - do 30 i = 1, nfree - k = index (i) +26 END DO + ELSE + DO 30 i = 1, nfree + k = INDEX (i) r (i) = - theta * (z (k) - x (k) ) - g (k) -30 end do - call bmv (m, sy, wt, col, wa (2 * m + 1), wa (1), info) - if (info.ne.0) then +30 END DO + CALL bmv (m, sy, wt, col, wa (2 * m + 1), wa (1), info) + IF (info.ne.0) THEN info = - 8 - return - endif + RETURN + ENDIF pointr = head - do 34 j = 1, col + DO 34 j = 1, col a1 = wa (j) a2 = theta * wa (col + j) - do 32 i = 1, nfree - k = index (i) + DO 32 i = 1, nfree + k = INDEX (i) r (i) = r (i) + wy (k, pointr) * a1 + ws (k, pointr) & * a2 -32 end do - pointr = mod (pointr, m) + 1 -34 end do +32 END DO + pointr = MOD (pointr, m) + 1 +34 END DO - endif + ENDIF - return + RETURN -end subroutine cmprlb +END SUBROUTINE cmprlb !======================= The end of cmprlb ============================= -subroutine errclb (n, m, factr, l, u, nbd, task, info, k) - character (len=60) :: task - integer :: n, m, info, k, nbd (n) +SUBROUTINE errclb (n, m, factr, l, u, nbd, task, info, k) + CHARACTER (len=60) :: task + INTEGER :: n, m, info, k, nbd (n) doubleprecision factr, l (n), u (n) @@ -1767,51 +1766,51 @@ subroutine errclb (n, m, factr, l, u, nbd, task, info, k) ! ! ! ************ - integer :: i + INTEGER :: i doubleprecision zero - parameter (zero = 0.0d0) + PARAMETER (zero = 0.0d0) ! Check the input arguments for errors. - if (n.le.0) task = 'ERROR: N .LE. 0' - if (m.le.0) task = 'ERROR: M .LE. 0' + IF (n.le.0) task = 'ERROR: N .LE. 0' + IF (m.le.0) task = 'ERROR: M .LE. 0' - if (factr.lt.zero) task = 'ERROR: FACTR .LT. 0' + IF (factr.lt.zero) task = 'ERROR: FACTR .LT. 0' ! Check the validity of the arrays nbd(i), u(i), and l(i). - do 10 i = 1, n - if (nbd (i) .lt.0.or.nbd (i) .gt.3) then + DO 10 i = 1, n + IF (nbd (i) .lt.0.or.nbd (i) .gt.3) THEN ! return task = 'ERROR: INVALID NBD' info = - 6 k = i - endif - if (nbd (i) .eq.2) then - if (l (i) .gt.u (i) ) then + ENDIF + IF (nbd (i) .eq.2) THEN + IF (l (i) .gt.u (i) ) THEN ! return task = 'ERROR: NO FEASIBLE SOLUTION' info = - 7 k = i - endif - endif + ENDIF + ENDIF -10 end do +10 END DO - return + RETURN -end subroutine errclb +END SUBROUTINE errclb !======================= The end of errclb ============================= -subroutine formk (n, nsub, ind, nenter, ileave, indx2, iupdat, & +SUBROUTINE formk (n, nsub, ind, nenter, ileave, indx2, iupdat, & updatd, wn, wn1, m, ws, wy, sy, theta, col, head, info) - integer :: n, nsub, m, col, head, nenter, ileave, iupdat, info, & + INTEGER :: n, nsub, m, col, head, nenter, ileave, iupdat, info, & ind (n), indx2 (n) doubleprecision theta, wn (2 * m, 2 * m), wn1 (2 * m, 2 * m), & ws (n, m), wy (n, m), sy (m, m) - logical :: updatd + LOGICAL :: updatd ! ************ ! ! Subroutine formk @@ -1934,32 +1933,32 @@ subroutine formk (n, nsub, ind, nenter, ileave, indx2, iupdat, & ! ! ! ************ - integer :: m2, ipntr, jpntr, iy, is, jy, js, is1, js1, k1, i, k, & + INTEGER :: m2, ipntr, jpntr, iy, is, jy, js, is1, js1, k1, i, k, & col2, pbegin, pend, dbegin, dend, upcl doubleprecision ddot, temp1, temp2, temp3, temp4 doubleprecision zero - parameter (zero = 0.0d0) + PARAMETER (zero = 0.0d0) ! Form the lower triangular part of ! WN1 = [Y' ZZ'Y L_a'+R_z'] ! [L_a+R_z S'AA'S ] ! where L_a is the strictly lower triangular part of S'AA'Y ! R_z is the upper triangular part of S'ZZ'Y. - if (updatd) then - if (iupdat.gt.m) then + IF (updatd) THEN + IF (iupdat.gt.m) THEN ! shift old part of WN1. - do 10 jy = 1, m - 1 + DO 10 jy = 1, m - 1 js = m + jy - call dcopy (m - jy, wn1 (jy + 1, jy + 1), 1, wn1 (jy, jy) & + CALL dcopy (m - jy, wn1 (jy + 1, jy + 1), 1, wn1 (jy, jy) & , 1) - call dcopy (m - jy, wn1 (js + 1, js + 1), 1, wn1 (js, js) & + CALL dcopy (m - jy, wn1 (js + 1, js + 1), 1, wn1 (js, js) & , 1) - call dcopy (m - 1, wn1 (m + 2, jy + 1), 1, wn1 (m + 1, & + CALL dcopy (m - 1, wn1 (m + 2, jy + 1), 1, wn1 (m + 1, & jy), 1) -10 end do +10 END DO - endif + ENDIF ! put new rows in blocks (1,1), (2,1) and (2,2). pbegin = 1 pend = nsub @@ -1968,172 +1967,172 @@ subroutine formk (n, nsub, ind, nenter, ileave, indx2, iupdat, & iy = col is = m + col ipntr = head+col - 1 - if (ipntr.gt.m) ipntr = ipntr - m + IF (ipntr.gt.m) ipntr = ipntr - m jpntr = head - do 20 jy = 1, col + DO 20 jy = 1, col js = m + jy temp1 = zero temp2 = zero temp3 = zero ! compute element jy of row 'col' of Y'ZZ'Y - do 15 k = pbegin, pend + DO 15 k = pbegin, pend k1 = ind (k) temp1 = temp1 + wy (k1, ipntr) * wy (k1, jpntr) -15 end do +15 END DO ! compute elements jy of row 'col' of L_a and S'AA'S - do 16 k = dbegin, dend + DO 16 k = dbegin, dend k1 = ind (k) temp2 = temp2 + ws (k1, ipntr) * ws (k1, jpntr) temp3 = temp3 + ws (k1, ipntr) * wy (k1, jpntr) -16 end do +16 END DO wn1 (iy, jy) = temp1 wn1 (is, js) = temp2 wn1 (is, jy) = temp3 - jpntr = mod (jpntr, m) + 1 + jpntr = MOD (jpntr, m) + 1 -20 end do +20 END DO ! put new column in block (2,1). jy = col jpntr = head+col - 1 - if (jpntr.gt.m) jpntr = jpntr - m + IF (jpntr.gt.m) jpntr = jpntr - m ipntr = head - do 30 i = 1, col + DO 30 i = 1, col is = m + i temp3 = zero ! compute element i of column 'col' of R_z - do 25 k = pbegin, pend + DO 25 k = pbegin, pend k1 = ind (k) temp3 = temp3 + ws (k1, ipntr) * wy (k1, jpntr) -25 end do - ipntr = mod (ipntr, m) + 1 +25 END DO + ipntr = MOD (ipntr, m) + 1 wn1 (is, jy) = temp3 -30 end do +30 END DO upcl = col - 1 - else + ELSE upcl = col - endif + ENDIF ! modify the old parts in blocks (1,1) and (2,2) due to changes ! in the set of free variables. ipntr = head - do 45 iy = 1, upcl + DO 45 iy = 1, upcl is = m + iy jpntr = head - do 40 jy = 1, iy + DO 40 jy = 1, iy js = m + jy temp1 = zero temp2 = zero temp3 = zero temp4 = zero - do 35 k = 1, nenter + DO 35 k = 1, nenter k1 = indx2 (k) temp1 = temp1 + wy (k1, ipntr) * wy (k1, jpntr) temp2 = temp2 + ws (k1, ipntr) * ws (k1, jpntr) -35 end do - do 36 k = ileave, n +35 END DO + DO 36 k = ileave, n k1 = indx2 (k) temp3 = temp3 + wy (k1, ipntr) * wy (k1, jpntr) temp4 = temp4 + ws (k1, ipntr) * ws (k1, jpntr) -36 end do +36 END DO wn1 (iy, jy) = wn1 (iy, jy) + temp1 - temp3 wn1 (is, js) = wn1 (is, js) - temp2 + temp4 - jpntr = mod (jpntr, m) + 1 -40 end do - ipntr = mod (ipntr, m) + 1 + jpntr = MOD (jpntr, m) + 1 +40 END DO + ipntr = MOD (ipntr, m) + 1 -45 end do +45 END DO ! modify the old parts in block (2,1). ipntr = head - do 60 is = m + 1, m + upcl + DO 60 is = m + 1, m + upcl jpntr = head - do 55 jy = 1, upcl + DO 55 jy = 1, upcl temp1 = zero temp3 = zero - do 50 k = 1, nenter + DO 50 k = 1, nenter k1 = indx2 (k) temp1 = temp1 + ws (k1, ipntr) * wy (k1, jpntr) -50 end do - do 51 k = ileave, n +50 END DO + DO 51 k = ileave, n k1 = indx2 (k) temp3 = temp3 + ws (k1, ipntr) * wy (k1, jpntr) -51 end do - if (is.le.jy + m) then +51 END DO + IF (is.le.jy + m) THEN wn1 (is, jy) = wn1 (is, jy) + temp1 - temp3 - else + ELSE wn1 (is, jy) = wn1 (is, jy) - temp1 + temp3 - endif - jpntr = mod (jpntr, m) + 1 -55 end do - ipntr = mod (ipntr, m) + 1 + ENDIF + jpntr = MOD (jpntr, m) + 1 +55 END DO + ipntr = MOD (ipntr, m) + 1 -60 end do +60 END DO ! Form the upper triangle of WN = [D+Y' ZZ'Y/theta -L_a'+R_z' ] ! [-L_a +R_z S'AA'S*theta] m2 = 2 * m - do 70 iy = 1, col + DO 70 iy = 1, col is = col + iy is1 = m + iy - do 65 jy = 1, iy + DO 65 jy = 1, iy js = col + jy js1 = m + jy wn (jy, iy) = wn1 (iy, jy) / theta wn (js, is) = wn1 (is1, js1) * theta -65 end do - do 66 jy = 1, iy - 1 +65 END DO + DO 66 jy = 1, iy - 1 wn (jy, is) = - wn1 (is1, jy) -66 end do - do 67 jy = iy, col +66 END DO + DO 67 jy = iy, col wn (jy, is) = wn1 (is1, jy) -67 end do +67 END DO wn (iy, iy) = wn (iy, iy) + sy (iy, iy) -70 end do +70 END DO ! Form the upper triangle of ! WN= [ LL' L^-1(-L_a'+R_z')] ' ! [(-L_a +R_z)L'^-1 S'AA'S*theta ] ' ! first Cholesky factor (1,1) block of wn to get LL' ' ! with L' stored in the upper triangle of wn. ' - call dpofa (wn, m2, col, info) - if (info.ne.0) then + CALL dpofa (wn, m2, col, info) + IF (info.ne.0) THEN info = - 1 - return - endif + RETURN + ENDIF ! then form L^-1(-L_a'+R_z') in the (1,2) block. col2 = 2 * col - do 71 js = col + 1, col2 - call dtrsl (wn, m2, col, wn (1, js), 11, info) + DO 71 js = col + 1, col2 + CALL dtrsl (wn, m2, col, wn (1, js), 11, info) -71 end do +71 END DO ! Form S'AA'S*theta + (L^-1(-L_a'+R_z'))'L^-1(-L_a'+R_z') in the ' ! upper triangle of (2,2) block of wn. - do 72 is = col + 1, col2 - do 74 js = is, col2 + DO 72 is = col + 1, col2 + DO 74 js = is, col2 wn (is, js) = wn (is, js) + ddot (col, wn (1, is), 1, wn (1, & js), 1) -74 end do +74 END DO -72 end do +72 END DO ! Cholesky factorization of (2,2) block of wn. - call dpofa (wn (col + 1, col + 1), m2, col, info) - if (info.ne.0) then + CALL dpofa (wn (col + 1, col + 1), m2, col, info) + IF (info.ne.0) THEN info = - 2 - return + RETURN - endif + ENDIF - return + RETURN -end subroutine formk +END SUBROUTINE formk !======================= The end of formk ============================== -subroutine formt (m, wt, sy, ss, col, theta, info) - integer :: m, col, info +SUBROUTINE formt (m, wt, sy, ss, col, theta, info) + INTEGER :: m, col, info doubleprecision theta, wt (m, m), sy (m, m), ss (m, m) @@ -2162,51 +2161,51 @@ subroutine formt (m, wt, sy, ss, col, theta, info) ! ! ! ************ - integer :: i, j, k, k1 + INTEGER :: i, j, k, k1 doubleprecision ddum doubleprecision zero - parameter (zero = 0.0d0) + PARAMETER (zero = 0.0d0) ! Form the upper half of T = theta*SS + L*D^(-1)*L', ' ! store T in the upper triangle of the array wt. - do 52 j = 1, col + DO 52 j = 1, col wt (1, j) = theta * ss (1, j) -52 end do - do 55 i = 2, col - do 54 j = i, col - k1 = min (i, j) - 1 +52 END DO + DO 55 i = 2, col + DO 54 j = i, col + k1 = MIN (i, j) - 1 ddum = zero - do 53 k = 1, k1 + DO 53 k = 1, k1 ddum = ddum + sy (i, k) * sy (j, k) / sy (k, k) -53 end do +53 END DO wt (i, j) = ddum + theta * ss (i, j) -54 end do +54 END DO -55 end do +55 END DO ! Cholesky factorize T to J*J' with ' ! J' stored in the upper triangle of wt. ' - call dpofa (wt, m, col, info) - if (info.ne.0) then + CALL dpofa (wt, m, col, info) + IF (info.ne.0) THEN info = - 3 - endif + ENDIF - return + RETURN -end subroutine formt +END SUBROUTINE formt !======================= The end of formt ============================== -subroutine freev (n, nfree, index, nenter, ileave, indx2, iwhere, & +SUBROUTINE freev (n, nfree, index, nenter, ileave, indx2, iwhere, & wrk, updatd, cnstnd, iprint, iter) - integer :: n, nfree, nenter, ileave, iprint, iter, index (n), & + INTEGER :: n, nfree, nenter, ileave, iprint, iter, INDEX (n), & indx2 (n), iwhere (n) - logical :: wrk, updatd, cnstnd + LOGICAL :: wrk, updatd, cnstnd ! ************ ! ! Subroutine freev @@ -2245,58 +2244,58 @@ subroutine freev (n, nfree, index, nenter, ileave, indx2, iwhere, & ! ! ************ - integer :: iact, i, k + INTEGER :: iact, i, k nenter = 0 ileave = n + 1 - if (iter.gt.0.and.cnstnd) then + IF (iter.gt.0.and.cnstnd) THEN ! count the entering and leaving variables. - do 20 i = 1, nfree - k = index (i) - if (iwhere (k) .gt.0) then + DO 20 i = 1, nfree + k = INDEX (i) + IF (iwhere (k) .gt.0) THEN ileave = ileave-1 indx2 (ileave) = k - if (iprint.ge.100) write ( cp_lbfgs_unit_nr, * ) 'Variable ', k,& + IF (iprint.ge.100) WRITE ( cp_lbfgs_unit_nr, * ) 'Variable ', k,& ' leaves the set of free variables' - endif -20 end do - do 22 i = 1 + nfree, n - k = index (i) - if (iwhere (k) .le.0) then + ENDIF +20 END DO + DO 22 i = 1 + nfree, n + k = INDEX (i) + IF (iwhere (k) .le.0) THEN nenter = nenter + 1 indx2 (nenter) = k - if (iprint.ge.100) write ( cp_lbfgs_unit_nr, * ) 'Variable ', k,& + IF (iprint.ge.100) WRITE ( cp_lbfgs_unit_nr, * ) 'Variable ', k,& ' enters the set of free variables' - endif -22 end do - if (iprint.ge.99) write ( cp_lbfgs_unit_nr, * ) n + 1 - ileave,& + ENDIF +22 END DO + IF (iprint.ge.99) WRITE ( cp_lbfgs_unit_nr, * ) n + 1 - ileave,& ' variables leave; ', nenter, ' variables enter' - endif + ENDIF - wrk = (ileave.lt.n + 1) .or. (nenter.gt.0) .or.updatd + wrk = (ileave.lt.n + 1) .OR. (nenter.gt.0) .or.updatd ! Find the index set of free and active variables at the GCP. nfree = 0 iact = n + 1 - do 24 i = 1, n - if (iwhere (i) .le.0) then + DO 24 i = 1, n + IF (iwhere (i) .le.0) THEN nfree = nfree+1 - index (nfree) = i - else + INDEX (nfree) = i + ELSE iact = iact - 1 - index (iact) = i - endif -24 end do + INDEX (iact) = i + ENDIF +24 END DO - if (iprint.ge.99) write ( cp_lbfgs_unit_nr, * ) nfree, & + IF (iprint.ge.99) WRITE ( cp_lbfgs_unit_nr, * ) nfree, & ' variables are free at GCP ', iter + 1 - return + RETURN -end subroutine freev +END SUBROUTINE freev !======================= The end of freev ============================== -subroutine hpsolb (n, t, iorder, iheap) - integer :: iheap, n, iorder (n) +SUBROUTINE hpsolb (n, t, iorder, iheap) + INTEGER :: iheap, n, iorder (n) doubleprecision t (n) @@ -2341,39 +2340,39 @@ subroutine hpsolb (n, t, iorder, iheap) ! in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. ! ! ************ - integer :: i, j, k, indxin, indxou + INTEGER :: i, j, k, indxin, indxou doubleprecision ddum, out - if (iheap.eq.0) then + IF (iheap.eq.0) THEN ! Rearrange the elements t(1) to t(n) to form a heap. - do 20 k = 2, n + DO 20 k = 2, n ddum = t (k) indxin = iorder (k) ! Add ddum to the heap. i = k -10 continue - if (i.gt.1) then +10 CONTINUE + IF (i.gt.1) THEN j = i / 2 - if (ddum.lt.t (j) ) then + IF (ddum.lt.t (j) ) THEN t (i) = t (j) iorder (i) = iorder (j) i = j - goto 10 - endif - endif + GOTO 10 + ENDIF + ENDIF t (i) = ddum iorder (i) = indxin -20 end do +20 END DO - endif + ENDIF ! Assign to 'out' the value of t(1), the least member of the heap, ! and rearrange the remaining members to form a heap as ! elements 1 to n-1 of t. - if (n.gt.1) then + IF (n.gt.1) THEN i = 1 out = t (1) indxou = iorder (1) @@ -2381,17 +2380,17 @@ subroutine hpsolb (n, t, iorder, iheap) indxin = iorder (n) ! Restore the heap -30 continue +30 CONTINUE j = i + i - if (j.le.n - 1) then - if (t (j + 1) .lt.t (j) ) j = j + 1 - if (t (j) .lt.ddum) then + IF (j.le.n - 1) THEN + IF (t (j + 1) .lt.t (j) ) j = j + 1 + IF (t (j) .lt.ddum) THEN t (i) = t (j) iorder (i) = iorder (j) i = j - goto 30 - endif - endif + GOTO 30 + ENDIF + ENDIF t (i) = ddum @@ -2400,20 +2399,20 @@ subroutine hpsolb (n, t, iorder, iheap) t (n) = out iorder (n) = indxou - endif + ENDIF - return + RETURN -end subroutine hpsolb +END SUBROUTINE hpsolb !====================== The end of hpsolb ============================== -subroutine lnsrlb (n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, & +SUBROUTINE lnsrlb (n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, & t, z, stp, dnorm, dtd, xstep, stpmx, iter, ifun, iback, nfgv, & info, task, boxed, cnstnd, csave, isave, dsave) - character (len=60) :: task, csave - logical :: boxed, cnstnd - integer :: n, iter, ifun, iback, nfgv, info, nbd (n), isave (2) + CHARACTER (len=60) :: task, csave + LOGICAL :: boxed, cnstnd + INTEGER :: n, iter, ifun, iback, nfgv, info, nbd (n), isave (2) doubleprecision f, fold, gd, gdold, stp, dnorm, dtd, xstep, stpmx, & x (n), l (n), u (n), g (n), d (n), r (n), t (n), z (n), dsave (13) @@ -2443,102 +2442,102 @@ subroutine lnsrlb (n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, & ! ! ! ********** - integer :: i + INTEGER :: i doubleprecision ddot, a1, a2 doubleprecision one, zero, big - parameter (one = 1.0d0, zero = 0.0d0, big = 1.0d+10) + PARAMETER (one = 1.0d0, zero = 0.0d0, big = 1.0d+10) doubleprecision ftol, gtol, xtol - parameter (ftol = 1.0d-3, gtol = 0.9d0, xtol = 0.1d0) + PARAMETER (ftol = 1.0d-3, gtol = 0.9d0, xtol = 0.1d0) - if (task (1:5) .eq.'FG_LN') goto 556 + IF (task (1:5) .EQ.'FG_LN') GOTO 556 dtd = ddot (n, d, 1, d, 1) - dnorm = sqrt (dtd) + dnorm = SQRT (dtd) ! Determine the maximum step length. stpmx = big - if (cnstnd) then - if (iter.eq.0) then + IF (cnstnd) THEN + IF (iter.eq.0) THEN stpmx = one - else - do 43 i = 1, n + ELSE + DO 43 i = 1, n a1 = d (i) - if (nbd (i) .ne.0) then - if (a1.lt.zero.and.nbd (i) .le.2) then + IF (nbd (i) .ne.0) THEN + IF (a1.lt.zero.and.nbd (i) .le.2) THEN a2 = l (i) - x (i) - if (a2.ge.zero) then + IF (a2.ge.zero) THEN stpmx = zero - elseif (a1 * stpmx.lt.a2) then + ELSEIF (a1 * stpmx.lt.a2) THEN stpmx = a2 / a1 - endif - elseif (a1.gt.zero.and.nbd (i) .ge.2) then + ENDIF + ELSEIF (a1.gt.zero.and.nbd (i) .ge.2) THEN a2 = u (i) - x (i) - if (a2.le.zero) then + IF (a2.le.zero) THEN stpmx = zero - elseif (a1 * stpmx.gt.a2) then + ELSEIF (a1 * stpmx.gt.a2) THEN stpmx = a2 / a1 - endif - endif - endif -43 end do - endif + ENDIF + ENDIF + ENDIF +43 END DO + ENDIF - endif - if (iter.eq.0.and..not.boxed) then - stp = min (one / dnorm, stpmx) - else + ENDIF + IF (iter.eq.0.and..not.boxed) THEN + stp = MIN (one / dnorm, stpmx) + ELSE stp = one - endif - call dcopy (n, x, 1, t, 1) - call dcopy (n, g, 1, r, 1) + ENDIF + CALL dcopy (n, x, 1, t, 1) + CALL dcopy (n, g, 1, r, 1) fold = f ifun = 0 iback = 0 csave = 'START' -556 continue +556 CONTINUE gd = ddot (n, g, 1, d, 1) - if (ifun.eq.0) then + IF (ifun.eq.0) THEN gdold = gd - if (gd.ge.zero) then + IF (gd.ge.zero) THEN ! the directional derivative >=0. ! Line search is impossible. info = - 4 - return - endif + RETURN + ENDIF - endif + ENDIF - call dcsrch (f, gd, stp, ftol, gtol, xtol, zero, stpmx, csave, & + CALL dcsrch (f, gd, stp, ftol, gtol, xtol, zero, stpmx, csave, & isave, dsave) xstep = stp * dnorm - if (csave (1:4) .ne.'CONV'.and.csave (1:4) .ne.'WARN') then + IF (csave (1:4) .NE.'CONV'.and.csave (1:4) .NE.'WARN') THEN task = 'FG_LNSRCH' ifun = ifun + 1 nfgv = nfgv + 1 iback = ifun - 1 - if (stp.eq.one) then - call dcopy (n, z, 1, x, 1) - else - do 41 i = 1, n + IF (stp.eq.one) THEN + CALL dcopy (n, z, 1, x, 1) + ELSE + DO 41 i = 1, n x (i) = stp * d (i) + t (i) -41 end do - endif - else +41 END DO + ENDIF + ELSE task = 'NEW_X' - endif + ENDIF - return + RETURN -end subroutine lnsrlb +END SUBROUTINE lnsrlb !======================= The end of lnsrlb ============================= -subroutine matupd (n, m, ws, wy, sy, ss, d, r, itail, iupdat, col, & +SUBROUTINE matupd (n, m, ws, wy, sy, ss, d, r, itail, iupdat, col, & head, theta, rr, dr, stp, dtd) - integer :: n, m, itail, iupdat, col, head + INTEGER :: n, m, itail, iupdat, col, head doubleprecision theta, rr, dr, stp, dtd, d (n), r (n), ws (n, m), & @@ -2566,27 +2565,27 @@ subroutine matupd (n, m, ws, wy, sy, ss, d, r, itail, iupdat, col, & ! ! ! ************ - integer :: j, pointr + INTEGER :: j, pointr doubleprecision ddot doubleprecision one - parameter (one = 1.0d0) + PARAMETER (one = 1.0d0) ! Set pointers for matrices WS and WY. - if (iupdat.le.m) then + IF (iupdat.le.m) THEN col = iupdat - itail = mod (head+iupdat - 2, m) + 1 - else - itail = mod (itail, m) + 1 - head = mod (head, m) + 1 + itail = MOD (head+iupdat - 2, m) + 1 + ELSE + itail = MOD (itail, m) + 1 + head = MOD (head, m) + 1 - endif + ENDIF ! Update matrices WS and WY. - call dcopy (n, d, 1, ws (1, itail), 1) + CALL dcopy (n, d, 1, ws (1, itail), 1) - call dcopy (n, r, 1, wy (1, itail), 1) + CALL dcopy (n, r, 1, wy (1, itail), 1) ! Set theta=yy/ys. @@ -2594,38 +2593,38 @@ subroutine matupd (n, m, ws, wy, sy, ss, d, r, itail, iupdat, col, & ! Form the middle matrix in B. ! update the upper triangle of SS, ! and the lower triangle of SY: - if (iupdat.gt.m) then + IF (iupdat.gt.m) THEN ! move old information - do 50 j = 1, col - 1 - call dcopy (j, ss (2, j + 1), 1, ss (1, j), 1) - call dcopy (col - j, sy (j + 1, j + 1), 1, sy (j, j), & + DO 50 j = 1, col - 1 + CALL dcopy (j, ss (2, j + 1), 1, ss (1, j), 1) + CALL dcopy (col - j, sy (j + 1, j + 1), 1, sy (j, j), & 1) -50 end do - endif +50 END DO + ENDIF ! add new information: the last row of SY ! and the last column of SS: pointr = head - do 51 j = 1, col - 1 + DO 51 j = 1, col - 1 sy (col, j) = ddot (n, d, 1, wy (1, pointr), 1) ss (j, col) = ddot (n, ws (1, pointr), 1, d, 1) - pointr = mod (pointr, m) + 1 -51 end do - if (stp.eq.one) then + pointr = MOD (pointr, m) + 1 +51 END DO + IF (stp.eq.one) THEN ss (col, col) = dtd - else + ELSE ss (col, col) = stp * stp * dtd - endif + ENDIF sy (col, col) = dr - return + RETURN -end subroutine matupd +END SUBROUTINE matupd !======================= The end of matupd ============================= -subroutine prn1lb (n, m, l, u, x, iprint, itfile, epsmch) - integer :: n, m, iprint, itfile +SUBROUTINE prn1lb (n, m, l, u, x, iprint, itfile, epsmch) + INTEGER :: n, m, iprint, itfile doubleprecision epsmch, x (n), l (n), u (n) @@ -2650,26 +2649,26 @@ subroutine prn1lb (n, m, l, u, x, iprint, itfile, epsmch) ! ! ************ - integer :: i - if (iprint.ge.0) then - write ( cp_lbfgs_unit_nr, 7001) epsmch - write ( cp_lbfgs_unit_nr, * ) 'N = ', n, ' M = ', m - if (iprint.ge.1) then - write (itfile, 2001) epsmch - write (itfile, * ) 'N = ', n, ' M = ', m - write (itfile, 9001) - if (iprint.gt.100) then - write ( cp_lbfgs_unit_nr, 1004) 'L =', (l (i) , i = 1, n) - write ( cp_lbfgs_unit_nr, 1004) 'X0 =', (x (i) , i = 1, n) - write ( cp_lbfgs_unit_nr, 1004) 'U =', (u (i) , i = 1, n) - endif - endif + INTEGER :: i + IF (iprint.ge.0) THEN + WRITE ( cp_lbfgs_unit_nr, 7001) epsmch + WRITE ( cp_lbfgs_unit_nr, * ) 'N = ', n, ' M = ', m + IF (iprint.ge.1) THEN + WRITE (itfile, 2001) epsmch + WRITE (itfile, * ) 'N = ', n, ' M = ', m + WRITE (itfile, 9001) + IF (iprint.gt.100) THEN + WRITE ( cp_lbfgs_unit_nr, 1004) 'L =', (l (i) , i = 1, n) + WRITE ( cp_lbfgs_unit_nr, 1004) 'X0 =', (x (i) , i = 1, n) + WRITE ( cp_lbfgs_unit_nr, 1004) 'U =', (u (i) , i = 1, n) + ENDIF + ENDIF - endif -1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) -2001 format ('RUNNING THE L-BFGS-B CODE',/,/, & + ENDIF +1004 FORMAT (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) +2001 FORMAT ('RUNNING THE L-BFGS-B CODE',/,/, & & 'it = iteration number',/, & - & 'nf = number of function evaluations',/, & + & 'nf = number of FUNCTION evaluations',/, & & 'nint = number of segments explored during the Cauchy search',/, & & 'nact = number of active bounds at the generalized Cauchy point' & & ,/, & @@ -2679,26 +2678,26 @@ subroutine prn1lb (n, m, l, u, x, iprint, itfile, epsmch) & 'stepl = step length used',/, & & 'tstep = norm of the displacement (total step)',/, & & 'projg = norm of the projected gradient',/, & - & 'f = function value',/,/, & + & 'f = FUNCTION value',/,/, & & ' * * *',/,/, & - & 'Machine precision =',1p,d10.3) -7001 format ('RUNNING THE L-BFGS-B CODE',/,/, & + & 'Machine PRECISION =',1p,d10.3) +7001 FORMAT ('RUNNING THE L-BFGS-B CODE',/,/, & & ' * * *',/,/, & - & 'Machine precision =',1p,d10.3) + & 'Machine PRECISION =',1p,d10.3) -9001 format (/,3x,'it',3x,'nf',2x,'nint',2x,'nact',2x,'sub',2x,'itls', & +9001 FORMAT (/,3x,'it',3x,'nf',2x,'nint',2x,'nact',2x,'sub',2x,'itls', & & 2x,'stepl',4x,'tstep',5x,'projg',8x,'f') - return + RETURN -end subroutine prn1lb +END SUBROUTINE prn1lb !======================= The end of prn1lb ============================= -subroutine prn2lb (n, x, f, g, iprint, itfile, iter, nfgv, nact, & +SUBROUTINE prn2lb (n, x, f, g, iprint, itfile, iter, nfgv, nact, & sbgnrm, nint, word, iword, iback, stp, xstep) - character (len=3) :: word - integer :: n, iprint, itfile, iter, nfgv, nact, nint, iword, & + CHARACTER (len=3) :: word + INTEGER :: n, iprint, itfile, iter, nfgv, nact, nint, iword, & iback @@ -2723,53 +2722,53 @@ subroutine prn2lb (n, x, f, g, iprint, itfile, iter, nfgv, nact, & ! ! ************ - integer :: i, imod + INTEGER :: i, imod ! 'word' records the status of subspace solutions. - if (iword.eq.0) then + IF (iword.eq.0) THEN ! the subspace minimization converged. word = 'con' - elseif (iword.eq.1) then + ELSEIF (iword.eq.1) THEN ! the subspace minimization stopped at a bound. word = 'bnd' - elseif (iword.eq.5) then + ELSEIF (iword.eq.5) THEN ! the truncated Newton step has been used. word = 'TNT' - else + ELSE word = '---' - endif - if (iprint.ge.99) then - write ( cp_lbfgs_unit_nr, * ) 'LINE SEARCH', iback, ' times; norm of step = ', & + ENDIF + IF (iprint.ge.99) THEN + WRITE ( cp_lbfgs_unit_nr, * ) 'LINE SEARCH', iback, ' times; norm of step = ', & xstep - write ( cp_lbfgs_unit_nr, 2001) iter, f, sbgnrm - if (iprint.gt.100) then - write ( cp_lbfgs_unit_nr, 1004) 'X =', (x (i) , i = 1, n) - write ( cp_lbfgs_unit_nr, 1004) 'G =', (g (i) , i = 1, n) - endif - elseif (iprint.gt.0) then - imod = mod (iter, iprint) - if (imod.eq.0) write ( cp_lbfgs_unit_nr, 2001) iter, f, sbgnrm - endif + WRITE ( cp_lbfgs_unit_nr, 2001) iter, f, sbgnrm + IF (iprint.gt.100) THEN + WRITE ( cp_lbfgs_unit_nr, 1004) 'X =', (x (i) , i = 1, n) + WRITE ( cp_lbfgs_unit_nr, 1004) 'G =', (g (i) , i = 1, n) + ENDIF + ELSEIF (iprint.gt.0) THEN + imod = MOD (iter, iprint) + IF (imod.eq.0) WRITE ( cp_lbfgs_unit_nr, 2001) iter, f, sbgnrm + ENDIF - if (iprint.ge.1) write (itfile, 3001) iter, nfgv, nint, nact, & + IF (iprint.ge.1) WRITE (itfile, 3001) iter, nfgv, nint, nact, & word, iback, stp, xstep, sbgnrm, f -1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) -2001 format & +1004 FORMAT (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) +2001 FORMAT & & (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) -3001 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d7.1),1p,2(1x,d10.3)) +3001 FORMAT(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d7.1),1p,2(1x,d10.3)) - return + RETURN -end subroutine prn2lb +END SUBROUTINE prn2lb !======================= The end of prn2lb ============================= -subroutine prn3lb (n, x, f, task, iprint, info, itfile, iter, & +SUBROUTINE prn3lb (n, x, f, task, iprint, info, itfile, iter, & nfgv, nintol, nskip, nact, sbgnrm, time, nint, word, iback, stp, & xstep, k, cachyt, sbtime, lnscht) - character (len=60) :: task - character (len=3) :: word - integer :: n, iprint, info, itfile, iter, nfgv, nintol, nskip, & + CHARACTER (len=60) :: task + CHARACTER (len=3) :: word + INTEGER :: n, iprint, info, itfile, iter, nfgv, nintol, nskip, & nact, nint, iback, k @@ -2796,107 +2795,107 @@ subroutine prn3lb (n, x, f, task, iprint, info, itfile, iter, & ! ! ************ - integer :: i + INTEGER :: i - if (task (1:5) .eq.'ERROR') goto 999 - if (iprint.ge.0) then - write ( cp_lbfgs_unit_nr, 3003) - write ( cp_lbfgs_unit_nr, 3004) - write ( cp_lbfgs_unit_nr, 3005) n, iter, nfgv, nintol, nskip, nact, sbgnrm, f - if (iprint.ge.100) then - write ( cp_lbfgs_unit_nr, 1004) 'X =', (x (i) , i = 1, n) - endif - if (iprint.ge.1) write ( cp_lbfgs_unit_nr, * ) ' F =', f - endif -999 continue - if (iprint.ge.0) then - write ( cp_lbfgs_unit_nr, 3009) task - if (info.ne.0) then - if (info.eq. - 1) write ( cp_lbfgs_unit_nr, 9011) - if (info.eq. - 2) write ( cp_lbfgs_unit_nr, 9012) - if (info.eq. - 3) write ( cp_lbfgs_unit_nr, 9013) - if (info.eq. - 4) write ( cp_lbfgs_unit_nr, 9014) - if (info.eq. - 5) write ( cp_lbfgs_unit_nr, 9015) - if (info.eq. - 6) write ( cp_lbfgs_unit_nr, * ) ' Input nbd(', k, ') is invalid.' - if (info.eq. - 7) write ( cp_lbfgs_unit_nr, * ) ' l(', k, ') > u(', k, & + IF (task (1:5) .EQ.'ERROR') GOTO 999 + IF (iprint.ge.0) THEN + WRITE ( cp_lbfgs_unit_nr, 3003) + WRITE ( cp_lbfgs_unit_nr, 3004) + WRITE ( cp_lbfgs_unit_nr, 3005) n, iter, nfgv, nintol, nskip, nact, sbgnrm, f + IF (iprint.ge.100) THEN + WRITE ( cp_lbfgs_unit_nr, 1004) 'X =', (x (i) , i = 1, n) + ENDIF + IF (iprint.ge.1) WRITE ( cp_lbfgs_unit_nr, * ) ' F =', f + ENDIF +999 CONTINUE + IF (iprint.ge.0) THEN + WRITE ( cp_lbfgs_unit_nr, 3009) task + IF (info.ne.0) THEN + IF (info.eq. - 1) WRITE ( cp_lbfgs_unit_nr, 9011) + IF (info.eq. - 2) WRITE ( cp_lbfgs_unit_nr, 9012) + IF (info.eq. - 3) WRITE ( cp_lbfgs_unit_nr, 9013) + IF (info.eq. - 4) WRITE ( cp_lbfgs_unit_nr, 9014) + IF (info.eq. - 5) WRITE ( cp_lbfgs_unit_nr, 9015) + IF (info.eq. - 6) WRITE ( cp_lbfgs_unit_nr, * ) ' Input nbd(', k, ') is invalid.' + IF (info.eq. - 7) WRITE ( cp_lbfgs_unit_nr, * ) ' l(', k, ') > u(', k, & '). No feasible solution.' - if (info.eq. - 8) write ( cp_lbfgs_unit_nr, 9018) - if (info.eq. - 9) write ( cp_lbfgs_unit_nr, 9019) - endif - if (iprint.ge.1) write ( cp_lbfgs_unit_nr, 3007) cachyt, sbtime, lnscht - write ( cp_lbfgs_unit_nr, 3008) time - if (iprint.ge.1) then - if (info.eq. - 4.or.info.eq. - 9) then - write (itfile, 3002) iter, nfgv, nint, nact, word, iback, & + IF (info.eq. - 8) WRITE ( cp_lbfgs_unit_nr, 9018) + IF (info.eq. - 9) WRITE ( cp_lbfgs_unit_nr, 9019) + ENDIF + IF (iprint.ge.1) WRITE ( cp_lbfgs_unit_nr, 3007) cachyt, sbtime, lnscht + WRITE ( cp_lbfgs_unit_nr, 3008) time + IF (iprint.ge.1) THEN + IF (info.eq. - 4.or.info.eq. - 9) THEN + WRITE (itfile, 3002) iter, nfgv, nint, nact, word, iback, & stp, xstep - endif - write (itfile, 3009) task - if (info.ne.0) then - if (info.eq. - 1) write (itfile, 9011) - if (info.eq. - 2) write (itfile, 9012) - if (info.eq. - 3) write (itfile, 9013) - if (info.eq. - 4) write (itfile, 9014) - if (info.eq. - 5) write (itfile, 9015) - if (info.eq. - 8) write (itfile, 9018) - if (info.eq. - 9) write (itfile, 9019) - endif - write (itfile, 3008) time - endif + ENDIF + WRITE (itfile, 3009) task + IF (info.ne.0) THEN + IF (info.eq. - 1) WRITE (itfile, 9011) + IF (info.eq. - 2) WRITE (itfile, 9012) + IF (info.eq. - 3) WRITE (itfile, 9013) + IF (info.eq. - 4) WRITE (itfile, 9014) + IF (info.eq. - 5) WRITE (itfile, 9015) + IF (info.eq. - 8) WRITE (itfile, 9018) + IF (info.eq. - 9) WRITE (itfile, 9019) + ENDIF + WRITE (itfile, 3008) time + ENDIF - endif -1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) -3002 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d7.1),6x,'-',10x,'-') -3003 format (/, & + ENDIF +1004 FORMAT (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) +3002 FORMAT(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d7.1),6x,'-',10x,'-') +3003 FORMAT (/, & & ' * * *',/,/, & & 'Tit = total number of iterations',/, & - & 'Tnf = total number of function evaluations',/, & + & 'Tnf = total number of FUNCTION evaluations',/, & & 'Tnint = total number of segments explored during', & & ' Cauchy searches',/, & & 'Skip = number of BFGS updates skipped',/, & & 'Nact = number of active bounds at final generalized', & & ' Cauchy point',/, & & 'Projg = norm of the final projected gradient',/, & - & 'F = final function value',/,/, & + & 'F = final FUNCTION value',/,/, & & ' * * *') -3004 format (/,3x,'N',3x,'Tit',2x,'Tnf',2x,'Tnint',2x, & +3004 FORMAT (/,3x,'N',3x,'Tit',2x,'Tnf',2x,'Tnint',2x, & & 'Skip',2x,'Nact',5x,'Projg',8x,'F') -3005 format (i5,2(1x,i4),(1x,i6),(2x,i4),(1x,i5),1p,2(2x,d10.3)) -3007 format (/,' Cauchy time',1p,e10.3,' seconds.',/ & +3005 FORMAT (i5,2(1x,i4),(1x,i6),(2x,i4),(1x,i5),1p,2(2x,d10.3)) +3007 FORMAT (/,' Cauchy time',1p,e10.3,' seconds.',/ & & ' Subspace minimization time',1p,e10.3,' seconds.',/ & & ' Line search time',1p,e10.3,' seconds.') -3008 format (/,' Total User time',1p,e10.3,' seconds.',/) -3009 format (/,a60) -9011 format (/, & +3008 FORMAT (/,' Total User time',1p,e10.3,' seconds.',/) +3009 FORMAT (/,a60) +9011 FORMAT (/, & &' Matrix in 1st Cholesky factorization in formk is not Pos. Def.') -9012 format (/, & +9012 FORMAT (/, & &' Matrix in 2st Cholesky factorization in formk is not Pos. Def.') -9013 format (/, & +9013 FORMAT (/, & &' Matrix in the Cholesky factorization in formt is not Pos. Def.') -9014 format (/, & +9014 FORMAT (/, & &' Derivative >= 0, backtracking line search impossible.',/, & &' Previous x, f and g restored.',/, & - &' Possible causes: 1 error in function or gradient evaluation;',/, & + &' Possible causes: 1 error in FUNCTION or gradient evaluation;',/, & &' 2 rounding errors dominate computation.') -9015 format (/, & - &' Warning: more than 10 function and gradient',/, & +9015 FORMAT (/, & + &' Warning: more than 10 FUNCTION and gradient',/, & &' evaluations in the last line search. Termination',/, & &' may possibly be caused by a bad search direction.') -9018 format (/,' The triangular system is singular.') +9018 FORMAT (/,' The triangular system is singular.') -9019 format (/, & - &' Line search cannot locate an adequate point after 20 function',/ & +9019 FORMAT (/, & + &' Line search cannot locate an adequate point after 20 FUNCTION',/ & &,' and gradient evaluations. Previous x, f and g restored.',/, & - &' Possible causes: 1 error in function or gradient evaluation;',/, & + &' Possible causes: 1 error in FUNCTION or gradient evaluation;',/, & &' 2 rounding error dominate computation.') - return + RETURN -end subroutine prn3lb +END SUBROUTINE prn3lb !======================= The end of prn3lb ============================= -subroutine projgr (n, l, u, nbd, x, g, sbgnrm) - integer :: n, nbd (n) +SUBROUTINE projgr (n, l, u, nbd, x, g, sbgnrm) + INTEGER :: n, nbd (n) doubleprecision sbgnrm, x (n), l (n), u (n), g (n) @@ -2919,34 +2918,34 @@ subroutine projgr (n, l, u, nbd, x, g, sbgnrm) ! ! ! ************ - integer :: i + INTEGER :: i doubleprecision gi doubleprecision zero - parameter (zero = 0.0d0) + PARAMETER (zero = 0.0d0) sbgnrm = zero - do 15 i = 1, n + DO 15 i = 1, n gi = g (i) - if (nbd (i) .ne.0) then - if (gi.lt.zero) then - if (nbd (i) .ge.2) gi = max ( (x (i) - u (i) ), gi) - else - if (nbd (i) .le.2) gi = min ( (x (i) - l (i) ), gi) - endif - endif - sbgnrm = max (sbgnrm, abs (gi) ) + IF (nbd (i) .ne.0) THEN + IF (gi.lt.zero) THEN + IF (nbd (i) .ge.2) gi = MAX ( (x (i) - u (i) ), gi) + ELSE + IF (nbd (i) .le.2) gi = MIN ( (x (i) - l (i) ), gi) + ENDIF + ENDIF + sbgnrm = MAX (sbgnrm, ABS (gi) ) -15 end do +15 END DO - return + RETURN -end subroutine projgr +END SUBROUTINE projgr !======================= The end of projgr ============================= -subroutine subsm (n, m, nsub, ind, l, u, nbd, x, d, ws, wy, theta, & +SUBROUTINE subsm (n, m, nsub, ind, l, u, nbd, x, d, ws, wy, theta, & col, head, iword, wv, wn, iprint, info) - integer :: n, m, nsub, col, head, iword, iprint, info, ind (nsub), & + INTEGER :: n, m, nsub, col, head, iword, iprint, info, ind (nsub), & nbd (n) @@ -3099,135 +3098,135 @@ subroutine subsm (n, m, nsub, ind, l, u, nbd, x, d, ws, wy, theta, & ! ! ! ************ - integer :: pointr, m2, col2, ibd, jy, js, i, j, k + INTEGER :: pointr, m2, col2, ibd, jy, js, i, j, k doubleprecision alpha, dk, temp1, temp2 doubleprecision one, zero - parameter (one = 1.0d0, zero = 0.0d0) - if (nsub.le.0) return + PARAMETER (one = 1.0d0, zero = 0.0d0) + IF (nsub.le.0) RETURN - if (iprint.ge.99) write ( cp_lbfgs_unit_nr, 1001) + IF (iprint.ge.99) WRITE ( cp_lbfgs_unit_nr, 1001) ! Compute wv = W'Zd. ' pointr = head - do 20 i = 1, col + DO 20 i = 1, col temp1 = zero temp2 = zero - do 10 j = 1, nsub + DO 10 j = 1, nsub k = ind (j) temp1 = temp1 + wy (k, pointr) * d (j) temp2 = temp2 + ws (k, pointr) * d (j) -10 end do +10 END DO wv (i) = temp1 wv (col + i) = theta * temp2 - pointr = mod (pointr, m) + 1 + pointr = MOD (pointr, m) + 1 -20 end do +20 END DO ! Compute wv:=K^(-1)wv. m2 = 2 * m col2 = 2 * col - call dtrsl (wn, m2, col2, wv, 11, info) - if (info.ne.0) return - do 25 i = 1, col + CALL dtrsl (wn, m2, col2, wv, 11, info) + IF (info.ne.0) RETURN + DO 25 i = 1, col wv (i) = - wv (i) -25 end do - call dtrsl (wn, m2, col2, wv, 01, info) +25 END DO + CALL dtrsl (wn, m2, col2, wv, 01, info) - if (info.ne.0) return + IF (info.ne.0) RETURN ! Compute d = (1/theta)d + (1/theta**2)Z'W wv. ' pointr = head - do 40 jy = 1, col + DO 40 jy = 1, col js = col + jy - do 30 i = 1, nsub + DO 30 i = 1, nsub k = ind (i) d (i) = d (i) + wy (k, pointr) * wv (jy) / theta + ws (k, & pointr) * wv (js) -30 end do - pointr = mod (pointr, m) + 1 -40 end do - do 50 i = 1, nsub +30 END DO + pointr = MOD (pointr, m) + 1 +40 END DO + DO 50 i = 1, nsub d (i) = d (i) / theta -50 end do +50 END DO ! Backtrack to the feasible region. alpha = one temp1 = alpha - do 60 i = 1, nsub + DO 60 i = 1, nsub k = ind (i) dk = d (i) - if (nbd (k) .ne.0) then - if (dk.lt.zero.and.nbd (k) .le.2) then + IF (nbd (k) .ne.0) THEN + IF (dk.lt.zero.and.nbd (k) .le.2) THEN temp2 = l (k) - x (k) - if (temp2.ge.zero) then + IF (temp2.ge.zero) THEN temp1 = zero - elseif (dk * alpha.lt.temp2) then + ELSEIF (dk * alpha.lt.temp2) THEN temp1 = temp2 / dk - endif - elseif (dk.gt.zero.and.nbd (k) .ge.2) then + ENDIF + ELSEIF (dk.gt.zero.and.nbd (k) .ge.2) THEN temp2 = u (k) - x (k) - if (temp2.le.zero) then + IF (temp2.le.zero) THEN temp1 = zero - elseif (dk * alpha.gt.temp2) then + ELSEIF (dk * alpha.gt.temp2) THEN temp1 = temp2 / dk - endif - endif - if (temp1.lt.alpha) then + ENDIF + ENDIF + IF (temp1.lt.alpha) THEN alpha = temp1 ibd = i - endif - endif + ENDIF + ENDIF -60 end do - if (alpha.lt.one) then +60 END DO + IF (alpha.lt.one) THEN dk = d (ibd) k = ind (ibd) - if (dk.gt.zero) then + IF (dk.gt.zero) THEN x (k) = u (k) d (ibd) = zero - elseif (dk.lt.zero) then + ELSEIF (dk.lt.zero) THEN x (k) = l (k) d (ibd) = zero - endif - endif - do 70 i = 1, nsub + ENDIF + ENDIF + DO 70 i = 1, nsub k = ind (i) x (k) = x (k) + alpha * d (i) -70 end do - if (iprint.ge.99) then - if (alpha.lt.one) then - write ( cp_lbfgs_unit_nr, 1002) alpha - else - write ( cp_lbfgs_unit_nr, * ) 'SM solution inside the box' - endif - if (iprint.gt.100) write ( cp_lbfgs_unit_nr, 1003) (x (i), i = 1, n) +70 END DO + IF (iprint.ge.99) THEN + IF (alpha.lt.one) THEN + WRITE ( cp_lbfgs_unit_nr, 1002) alpha + ELSE + WRITE ( cp_lbfgs_unit_nr, * ) 'SM solution inside the box' + ENDIF + IF (iprint.gt.100) WRITE ( cp_lbfgs_unit_nr, 1003) (x (i), i = 1, n) - endif - if (alpha.lt.one) then + ENDIF + IF (alpha.lt.one) THEN iword = 1 - else + ELSE iword = 0 - endif + ENDIF - if (iprint.ge.99) write ( cp_lbfgs_unit_nr, 1004) -1001 format (/,'----------------SUBSM entered-----------------',/) -1002 format ( 'ALPHA = ',f7.5,' backtrack to the BOX') -1003 format ('Subspace solution X = ',/,(4x,1p,6(1x,d11.4))) + IF (iprint.ge.99) WRITE ( cp_lbfgs_unit_nr, 1004) +1001 FORMAT (/,'----------------SUBSM entered-----------------',/) +1002 FORMAT ( 'ALPHA = ',f7.5,' backtrack to the BOX') +1003 FORMAT ('Subspace solution X = ',/,(4x,1p,6(1x,d11.4))) -1004 format (/,'----------------exit SUBSM --------------------',/) +1004 FORMAT (/,'----------------EXIT SUBSM --------------------',/) - return + RETURN -end subroutine subsm +END SUBROUTINE subsm !====================== The end of subsm =============================== -subroutine dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & +SUBROUTINE dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & task, isave, dsave) - character (len=*) :: task - integer :: isave (2) + CHARACTER (len=*) :: task + INTEGER :: isave (2) doubleprecision f, g, stp, ftol, gtol, xtol, stpmin, stpmax doubleprecision dsave (13) ! ********** @@ -3363,12 +3362,12 @@ subroutine dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & ! ! ********** doubleprecision zero, p5, p66 - parameter (zero = 0.0d0, p5 = 0.5d0, p66 = 0.66d0) + PARAMETER (zero = 0.0d0, p5 = 0.5d0, p66 = 0.66d0) doubleprecision xtrapl, xtrapu - parameter (xtrapl = 1.1d0, xtrapu = 4.0d0) - logical :: brackt - integer :: stage + PARAMETER (xtrapl = 1.1d0, xtrapu = 4.0d0) + LOGICAL :: brackt + INTEGER :: stage doubleprecision finit, ftest, fm, fx, fxm, fy, fym, ginit, gtest, & @@ -3376,24 +3375,24 @@ subroutine dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & ! Initialization block. - if (task (1:5) .eq.'START') then + IF (task (1:5) .EQ.'START') THEN ! Check the input arguments for errors. - if (stp.lt.stpmin) task = 'ERROR: STP .LT. STPMIN' - if (stp.gt.stpmax) task = 'ERROR: STP .GT. STPMAX' - if (g.ge.zero) task = 'ERROR: INITIAL G .GE. ZERO' - if (ftol.lt.zero) task = 'ERROR: FTOL .LT. ZERO' - if (gtol.lt.zero) task = 'ERROR: GTOL .LT. ZERO' - if (xtol.lt.zero) task = 'ERROR: XTOL .LT. ZERO' - if (stpmin.lt.zero) task = 'ERROR: STPMIN .LT. ZERO' + IF (stp.lt.stpmin) task = 'ERROR: STP .LT. STPMIN' + IF (stp.gt.stpmax) task = 'ERROR: STP .GT. STPMAX' + IF (g.ge.zero) task = 'ERROR: INITIAL G .GE. ZERO' + IF (ftol.lt.zero) task = 'ERROR: FTOL .LT. ZERO' + IF (gtol.lt.zero) task = 'ERROR: GTOL .LT. ZERO' + IF (xtol.lt.zero) task = 'ERROR: XTOL .LT. ZERO' + IF (stpmin.lt.zero) task = 'ERROR: STPMIN .LT. ZERO' - if (stpmax.lt.stpmin) task = 'ERROR: STPMAX .LT. STPMIN' + IF (stpmax.lt.stpmin) task = 'ERROR: STPMAX .LT. STPMIN' ! Exit if there are errors on input. - if (task (1:5) .eq.'ERROR') return + IF (task (1:5) .EQ.'ERROR') RETURN ! Initialize local variables. - brackt = .false. + brackt = .FALSE. stage = 1 finit = f ginit = g @@ -3419,16 +3418,16 @@ subroutine dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & task = 'FG' - goto 1000 + GOTO 1000 - else + ELSE ! Restore local variables. - if (isave (1) .eq.1) then - brackt = .true. - else - brackt = .false. - endif + IF (isave (1) .eq.1) THEN + brackt = .TRUE. + ELSE + brackt = .FALSE. + ENDIF stage = isave (2) ginit = dsave (1) gtest = dsave (2) @@ -3446,39 +3445,39 @@ subroutine dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & width1 = dsave (13) - endif + ENDIF ! If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the ' ! algorithm enters the second stage. ftest = finit + stp * gtest - if (stage.eq.1.and.f.le.ftest.and.g.ge.zero) stage = 2 + IF (stage.eq.1.and.f.le.ftest.and.g.ge.zero) stage = 2 ! Test for warnings. - if (brackt.and. (stp.le.stmin.or.stp.ge.stmax) ) task = & + IF (brackt.and. (stp.le.stmin.or.stp.ge.stmax) ) task = & 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' - if (brackt.and.stmax - stmin.le.xtol * stmax) task = & + IF (brackt.and.stmax - stmin.le.xtol * stmax) task = & 'WARNING: XTOL TEST SATISFIED' - if (stp.eq.stpmax.and.f.le.ftest.and.g.le.gtest) task =& + IF (stp.eq.stpmax.and.f.le.ftest.and.g.le.gtest) task =& 'WARNING: STP = STPMAX' - if (stp.eq.stpmin.and. (f.gt.ftest.or.g.ge.gtest) ) task = & + IF (stp.eq.stpmin.and. (f.gt.ftest.or.g.ge.gtest) ) task = & 'WARNING: STP = STPMIN' ! Test for convergence. - if (f.le.ftest.and.abs (g) .le.gtol * ( - ginit) ) task = & + IF (f.le.ftest.and.ABS (g) .le.gtol * ( - ginit) ) task = & 'CONVERGENCE' ! Test for termination. - if (task (1:4) .eq.'WARN'.or.task (1:4) .eq.'CONV') goto 1000 + IF (task (1:4) .EQ.'WARN'.or.task (1:4) .EQ.'CONV') GOTO 1000 ! A modified function is used to predict the step during the ! first stage if a lower function value has been obtained but ! the decrease is not sufficient. - if (stage.eq.1.and.f.le.fx.and.f.gt.ftest) then + IF (stage.eq.1.and.f.le.fx.and.f.gt.ftest) THEN ! Define the modified function and derivative values. fm = f - stp * gtest fxm = fx - stx * gtest @@ -3491,7 +3490,7 @@ subroutine dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & ! Call dcstep to update stx, sty, and to compute the new step. - call dcstep (stx, fxm, gxm, sty, fym, gym, stp, fm, gm, brackt, & + CALL dcstep (stx, fxm, gxm, sty, fym, gym, stp, fm, gm, brackt, & stmin, stmax) ! Reset the function and derivative values for f. fx = fxm + stx * gtest @@ -3501,56 +3500,56 @@ subroutine dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & gy = gym + gtest - else + ELSE ! Call dcstep to update stx, sty, and to compute the new step. - call dcstep (stx, fx, gx, sty, fy, gy, stp, f, g, brackt, & + CALL dcstep (stx, fx, gx, sty, fy, gy, stp, f, g, brackt, & stmin, stmax) - endif + ENDIF ! Decide if a bisection step is needed. - if (brackt) then - if (abs (sty - stx) .ge.p66 * width1) stp = stx + p5 * (sty - & + IF (brackt) THEN + IF (ABS (sty - stx) .ge.p66 * width1) stp = stx + p5 * (sty - & stx) width1 = width - width = abs (sty - stx) + width = ABS (sty - stx) - endif + ENDIF ! Set the minimum and maximum steps allowed for stp. - if (brackt) then - stmin = min (stx, sty) - stmax = max (stx, sty) - else + IF (brackt) THEN + stmin = MIN (stx, sty) + stmax = MAX (stx, sty) + ELSE stmin = stp + xtrapl * (stp - stx) stmax = stp + xtrapu * (stp - stx) - endif + ENDIF ! Force the step to be within the bounds stpmax and stpmin. - stp = max (stp, stpmin) + stp = MAX (stp, stpmin) - stp = min (stp, stpmax) + stp = MIN (stp, stpmax) ! If further progress is not possible, let stp be the best ! point obtained during the search. - if (brackt.and. (stp.le.stmin.or.stp.ge.stmax) .or. ( & + IF (brackt.and. (stp.le.stmin.or.stp.ge.stmax) .OR. ( & brackt.and.stmax - stmin.le.xtol * stmax) ) stp = stx ! Obtain another function and derivative. task = 'FG' -1000 continue +1000 CONTINUE ! Save local variables. - if (brackt) then + IF (brackt) THEN isave (1) = 1 - else + ELSE isave (1) = 0 - endif + ENDIF isave (2) = stage dsave (1) = ginit dsave (2) = gtest @@ -3568,11 +3567,11 @@ subroutine dcsrch (f, g, stp, ftol, gtol, xtol, stpmin, stpmax, & dsave (13) = width1 -end subroutine dcsrch +END SUBROUTINE dcsrch !====================== The end of dcsrch ============================== -subroutine dcstep (stx, fx, dx, sty, fy, dy, stp, fp, dp, brackt, & +SUBROUTINE dcstep (stx, fx, dx, sty, fy, dy, stp, fp, dp, brackt, & stpmin, stpmax) - logical :: brackt + LOGICAL :: brackt doubleprecision stx, fx, dx, sty, fy, dy, stp, fp, dp, stpmin, & stpmax ! ********** @@ -3669,62 +3668,62 @@ subroutine dcstep (stx, fx, dx, sty, fy, dy, stp, fp, dp, brackt, & ! ********** doubleprecision zero, p66, two, three - parameter (zero = 0.0d0, p66 = 0.66d0, two = 2.0d0, three = 3.0d0) + PARAMETER (zero = 0.0d0, p66 = 0.66d0, two = 2.0d0, three = 3.0d0) doubleprecision gamma, p, q, r, s, sgnd, stpc, stpf, stpq, theta - sgnd = dp * (dx / abs (dx) ) + sgnd = dp * (dx / ABS (dx) ) ! First case: A higher function value. The minimum is bracketed. ! If the cubic step is closer to stx than the quadratic step, the ! cubic step is taken, otherwise the average of the cubic and ! quadratic steps is taken. - if (fp.gt.fx) then + IF (fp.gt.fx) THEN theta = three * (fx - fp) / (stp - stx) + dx + dp - s = max (abs (theta), abs (dx), abs (dp) ) - gamma = s * sqrt ( (theta / s) **2 - (dx / s) * (dp / s) ) - if (stp.lt.stx) gamma = - gamma + s = MAX (ABS (theta), ABS (dx), ABS (dp) ) + gamma = s * SQRT ( (theta / s) **2 - (dx / s) * (dp / s) ) + IF (stp.lt.stx) gamma = - gamma p = (gamma - dx) + theta q = ( (gamma - dx) + gamma) + dp r = p / q stpc = stx + r * (stp - stx) stpq = stx + ( (dx / ( (fx - fp) / (stp - stx) + dx) ) / two) & * (stp - stx) - if (abs (stpc - stx) .lt.abs (stpq - stx) ) then + IF (ABS (stpc - stx) .lt.ABS (stpq - stx) ) THEN stpf = stpc - else + ELSE stpf = stpc + (stpq - stpc) / two - endif + ENDIF - brackt = .true. + brackt = .TRUE. ! Second case: A lower function value and derivatives of opposite ! sign. The minimum is bracketed. If the cubic step is farther from ! stp than the secant step, the cubic step is taken, otherwise the ! secant step is taken. - elseif (sgnd.lt.zero) then + ELSEIF (sgnd.lt.zero) THEN theta = three * (fx - fp) / (stp - stx) + dx + dp - s = max (abs (theta), abs (dx), abs (dp) ) - gamma = s * sqrt ( (theta / s) **2 - (dx / s) * (dp / s) ) - if (stp.gt.stx) gamma = - gamma + s = MAX (ABS (theta), ABS (dx), ABS (dp) ) + gamma = s * SQRT ( (theta / s) **2 - (dx / s) * (dp / s) ) + IF (stp.gt.stx) gamma = - gamma p = (gamma - dp) + theta q = ( (gamma - dp) + gamma) + dx r = p / q stpc = stp + r * (stx - stp) stpq = stp + (dp / (dp - dx) ) * (stx - stp) - if (abs (stpc - stp) .gt.abs (stpq - stp) ) then + IF (ABS (stpc - stp) .gt.ABS (stpq - stp) ) THEN stpf = stpc - else + ELSE stpf = stpq - endif + ENDIF - brackt = .true. + brackt = .TRUE. ! Third case: A lower function value, derivatives of the same sign, ! and the magnitude of the derivative decreases. - elseif (abs (dp) .lt.abs (dx) ) then + ELSEIF (ABS (dp) .lt.ABS (dx) ) THEN ! The cubic step is computed only if the cubic tends to infinity ! in the direction of the step or if the minimum of the cubic ! is beyond stp. Otherwise the cubic step is defined to be the @@ -3732,104 +3731,104 @@ subroutine dcstep (stx, fx, dx, sty, fy, dy, stp, fp, dp, brackt, & theta = three * (fx - fp) / (stp - stx) + dx + dp - s = max (abs (theta), abs (dx), abs (dp) ) + s = MAX (ABS (theta), ABS (dx), ABS (dp) ) ! The case gamma = 0 only arises if the cubic does not tend ! to infinity in the direction of the step. - gamma = s * sqrt (max (zero, (theta / s) **2 - (dx / s) & + gamma = s * SQRT (MAX (zero, (theta / s) **2 - (dx / s) & * (dp / s) ) ) - if (stp.gt.stx) gamma = - gamma + IF (stp.gt.stx) gamma = - gamma p = (gamma - dp) + theta q = (gamma + (dx - dp) ) + gamma r = p / q - if (r.lt.zero.and.gamma.ne.zero) then + IF (r.lt.zero.and.gamma.ne.zero) THEN stpc = stp + r * (stx - stp) - elseif (stp.gt.stx) then + ELSEIF (stp.gt.stx) THEN stpc = stpmax - else + ELSE stpc = stpmin - endif + ENDIF stpq = stp + (dp / (dp - dx) ) * (stx - stp) - if (brackt) then + IF (brackt) THEN ! A minimizer has been bracketed. If the cubic step is ! closer to stp than the secant step, the cubic step is ! taken, otherwise the secant step is taken. - if (abs (stpc - stp) .lt.abs (stpq - stp) ) then + IF (ABS (stpc - stp) .lt.ABS (stpq - stp) ) THEN stpf = stpc - else + ELSE stpf = stpq - endif - if (stp.gt.stx) then - stpf = min (stp + p66 * (sty - stp), stpf) - else - stpf = max (stp + p66 * (sty - stp), stpf) - endif + ENDIF + IF (stp.gt.stx) THEN + stpf = MIN (stp + p66 * (sty - stp), stpf) + ELSE + stpf = MAX (stp + p66 * (sty - stp), stpf) + ENDIF - else + ELSE ! A minimizer has not been bracketed. If the cubic step is ! farther from stp than the secant step, the cubic step is ! taken, otherwise the secant step is taken. - if (abs (stpc - stp) .gt.abs (stpq - stp) ) then + IF (ABS (stpc - stp) .gt.ABS (stpq - stp) ) THEN stpf = stpc - else + ELSE stpf = stpq - endif - stpf = min (stpmax, stpf) - stpf = max (stpmin, stpf) + ENDIF + stpf = MIN (stpmax, stpf) + stpf = MAX (stpmin, stpf) - endif + ENDIF ! Fourth case: A lower function value, derivatives of the ! same sign, and the magnitude of the derivative does not ! decrease. If the minimum is not bracketed, the step is either ! stpmin or stpmax, otherwise the cubic step is taken. - else - if (brackt) then + ELSE + IF (brackt) THEN theta = three * (fp - fy) / (sty - stp) + dy + dp - s = max (abs (theta), abs (dy), abs (dp) ) - gamma = s * sqrt ( (theta / s) **2 - (dy / s) * (dp / s) ) - if (stp.gt.sty) gamma = - gamma + s = MAX (ABS (theta), ABS (dy), ABS (dp) ) + gamma = s * SQRT ( (theta / s) **2 - (dy / s) * (dp / s) ) + IF (stp.gt.sty) gamma = - gamma p = (gamma - dp) + theta q = ( (gamma - dp) + gamma) + dy r = p / q stpc = stp + r * (sty - stp) stpf = stpc - elseif (stp.gt.stx) then + ELSEIF (stp.gt.stx) THEN stpf = stpmax - else + ELSE stpf = stpmin - endif + ENDIF - endif + ENDIF ! Update the interval which contains a minimizer. - if (fp.gt.fx) then + IF (fp.gt.fx) THEN sty = stp fy = fp dy = dp - else - if (sgnd.lt.zero) then + ELSE + IF (sgnd.lt.zero) THEN sty = stx fy = fx dy = dx - endif + ENDIF stx = stp fx = fp dx = dp - endif + ENDIF ! Compute the new step. stp = stpf -end subroutine dcstep +END SUBROUTINE dcstep !====================== The end of dcstep ============================== -subroutine timer (ttime) +SUBROUTINE timer (ttime) doubleprecision ttime ! ********* ! @@ -3867,14 +3866,14 @@ subroutine timer (ttime) ! changed by fawzi to use machine, only: m_cputime ttime = m_cputime() - return + RETURN -end subroutine timer +END SUBROUTINE timer !====================== The end of timer =============================== -function dnrm2 (n, x, incx) +FUNCTION dnrm2 (n, x, incx) doubleprecision dnrm2 - integer :: n , incx + INTEGER :: n , incx doubleprecision :: x (n) ! ********** ! @@ -3905,32 +3904,32 @@ function dnrm2 (n, x, incx) ! Brett M. Averick. ! ! ********** - integer :: i + INTEGER :: i doubleprecision scale dnrm2 = 0.0d0 scale = 0.0d0 - do 10 i = 1, n, incx - scale = max (scale, abs (x (i) ) ) + DO 10 i = 1, n, incx + scale = MAX (scale, ABS (x (i) ) ) -10 end do +10 END DO - if (scale.eq.0.0d0) return - do 20 i = 1, n, incx + IF (scale.eq.0.0d0) RETURN + DO 20 i = 1, n, incx dnrm2 = dnrm2 + (x (i) / scale) **2 -20 end do +20 END DO - dnrm2 = scale * sqrt (dnrm2) + dnrm2 = scale * SQRT (dnrm2) - return + RETURN -end function dnrm2 +END FUNCTION dnrm2 !====================== The end of dnrm2 =============================== -function dpmeps () +FUNCTION dpmeps () ! ********** ! ! Subroutine dpeps @@ -3961,161 +3960,161 @@ function dpmeps () ! ! ******* doubleprecision ::dpmeps - integer :: i, ibeta, irnd, it, itemp, negep + INTEGER :: i, ibeta, irnd, it, itemp, negep doubleprecision a, b, beta, betain, betah, temp, tempa, temp1, & zero, one, two - data zero, one, two / 0.0d0, 1.0d0, 2.0d0 / + DATA zero, one, two / 0.0d0, 1.0d0, 2.0d0 / ! determine ibeta, beta ala malcolm. a = one b = one -10 continue +10 CONTINUE a = a + a temp = a + one temp1 = temp - a - if (temp1 - one.eq.zero) goto 10 -20 continue + IF (temp1 - one.eq.zero) GOTO 10 +20 CONTINUE b = b + b temp = a + b - itemp = int (temp - a) - if (itemp.eq.0) goto 20 + itemp = INT (temp - a) + IF (itemp.eq.0) GOTO 20 ibeta = itemp - beta = dble (ibeta) + beta = DBLE (ibeta) ! determine it, irnd. it = 0 b = one -30 continue +30 CONTINUE it = it + 1 b = b * beta temp = b + one temp1 = temp - b - if (temp1 - one.eq.zero) goto 30 + IF (temp1 - one.eq.zero) GOTO 30 irnd = 0 betah = beta / two temp = a + betah - if (temp - a.ne.zero) irnd = 1 + IF (temp - a.ne.zero) irnd = 1 tempa = a + beta temp = tempa + betah - if ( (irnd.eq.0) .and. (temp - tempa.ne.zero) ) irnd = 2 + IF ( (irnd.eq.0) .AND. (temp - tempa.ne.zero) ) irnd = 2 ! determine dpmeps. negep = it + 3 betain = one / beta a = one - do 40 i = 1, negep + DO 40 i = 1, negep a = a * betain -40 end do -50 continue +40 END DO +50 CONTINUE temp = one+a - if (temp - one.ne.zero) goto 60 + IF (temp - one.ne.zero) GOTO 60 a = a * beta - goto 50 -60 continue + GOTO 50 +60 CONTINUE dpmeps = a - if ( (ibeta.eq.2) .or. (irnd.eq.0) ) goto 70 + IF ( (ibeta.eq.2) .OR. (irnd.eq.0) ) GOTO 70 a = (a * (one+a) ) / two temp = one+a - if (temp - one.ne.zero) dpmeps = a + IF (temp - one.ne.zero) dpmeps = a -70 return +70 RETURN -end function dpmeps +END FUNCTION dpmeps !====================== The end of dpmeps ============================== -subroutine daxpy (n, da, dx, incx, dy, incy) +SUBROUTINE daxpy (n, da, dx, incx, dy, incy) ! ! constant times a vector plus a vector. ! uses unrolled loops for increments equal to one. ! jack dongarra, linpack, 3/11/78. ! doubleprecision dx ( * ), dy ( * ), da - integer :: i, incx, incy, ix, iy, m, mp1, n + INTEGER :: i, incx, incy, ix, iy, m, mp1, n ! - if (n.le.0) return - if (da.eq.0.0d0) return - if (incx.eq.1.and.incy.eq.1) goto 20 + IF (n.le.0) RETURN + IF (da.eq.0.0d0) RETURN + IF (incx.eq.1.and.incy.eq.1) GOTO 20 ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 - if (incx.lt.0) ix = ( - n + 1) * incx + 1 - if (incy.lt.0) iy = ( - n + 1) * incy + 1 - do 10 i = 1, n + IF (incx.lt.0) ix = ( - n + 1) * incx + 1 + IF (incy.lt.0) iy = ( - n + 1) * incy + 1 + DO 10 i = 1, n dy (iy) = dy (iy) + da * dx (ix) ix = ix + incx iy = iy + incy -10 end do - return +10 END DO + RETURN ! ! code for both increments equal to 1 ! ! ! clean-up loop ! -20 m = mod (n, 4) - if (m.eq.0) goto 40 - do 30 i = 1, m +20 m = MOD (n, 4) + IF (m.eq.0) GOTO 40 + DO 30 i = 1, m dy (i) = dy (i) + da * dx (i) -30 end do - if (n.lt.4) return +30 END DO + IF (n.lt.4) RETURN 40 mp1 = m + 1 - do 50 i = mp1, n, 4 + DO 50 i = mp1, n, 4 dy (i) = dy (i) + da * dx (i) dy (i + 1) = dy (i + 1) + da * dx (i + 1) dy (i + 2) = dy (i + 2) + da * dx (i + 2) dy (i + 3) = dy (i + 3) + da * dx (i + 3) -50 end do - return +50 END DO + RETURN -end subroutine daxpy +END SUBROUTINE daxpy !====================== The end of daxpy =============================== -subroutine dcopy (n, dx, incx, dy, incy) +SUBROUTINE dcopy (n, dx, incx, dy, incy) ! ! copies a vector, x, to a vector, y. ! uses unrolled loops for increments equal to one. ! jack dongarra, linpack, 3/11/78. ! doubleprecision dx ( * ), dy ( * ) - integer :: i, incx, incy, ix, iy, m, mp1, n + INTEGER :: i, incx, incy, ix, iy, m, mp1, n ! - if (n.le.0) return - if (incx.eq.1.and.incy.eq.1) goto 20 + IF (n.le.0) RETURN + IF (incx.eq.1.and.incy.eq.1) GOTO 20 ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 - if (incx.lt.0) ix = ( - n + 1) * incx + 1 - if (incy.lt.0) iy = ( - n + 1) * incy + 1 - do 10 i = 1, n + IF (incx.lt.0) ix = ( - n + 1) * incx + 1 + IF (incy.lt.0) iy = ( - n + 1) * incy + 1 + DO 10 i = 1, n dy (iy) = dx (ix) ix = ix + incx iy = iy + incy -10 end do - return +10 END DO + RETURN ! ! code for both increments equal to 1 ! ! ! clean-up loop ! -20 m = mod (n, 7) - if (m.eq.0) goto 40 - do 30 i = 1, m +20 m = MOD (n, 7) + IF (m.eq.0) GOTO 40 + DO 30 i = 1, m dy (i) = dx (i) -30 end do - if (n.lt.7) return +30 END DO + IF (n.lt.7) RETURN 40 mp1 = m + 1 - do 50 i = mp1, n, 7 + DO 50 i = mp1, n, 7 dy (i) = dx (i) dy (i + 1) = dx (i + 1) dy (i + 2) = dx (i + 2) @@ -4123,13 +4122,13 @@ subroutine dcopy (n, dx, incx, dy, incy) dy (i + 4) = dx (i + 4) dy (i + 5) = dx (i + 5) dy (i + 6) = dx (i + 6) -50 end do - return +50 END DO + RETURN -end subroutine dcopy +END SUBROUTINE dcopy !====================== The end of dcopy =============================== -function ddot (n, dx, incx, dy, incy) +FUNCTION ddot (n, dx, incx, dy, incy) ! ! forms the dot product of two vectors. ! uses unrolled loops for increments equal to one. @@ -4137,53 +4136,53 @@ function ddot (n, dx, incx, dy, incy) ! doubleprecision ddot doubleprecision dx ( * ), dy ( * ), dtemp - integer :: i, incx, incy, ix, iy, m, mp1, n + INTEGER :: i, incx, incy, ix, iy, m, mp1, n ! ddot = 0.0d0 dtemp = 0.0d0 - if (n.le.0) return - if (incx.eq.1.and.incy.eq.1) goto 20 + IF (n.le.0) RETURN + IF (incx.eq.1.and.incy.eq.1) GOTO 20 ! ! code for unequal increments or equal increments ! not equal to 1 ! ix = 1 iy = 1 - if (incx.lt.0) ix = ( - n + 1) * incx + 1 - if (incy.lt.0) iy = ( - n + 1) * incy + 1 - do 10 i = 1, n + IF (incx.lt.0) ix = ( - n + 1) * incx + 1 + IF (incy.lt.0) iy = ( - n + 1) * incy + 1 + DO 10 i = 1, n dtemp = dtemp + dx (ix) * dy (iy) ix = ix + incx iy = iy + incy -10 end do +10 END DO ddot = dtemp - return + RETURN ! ! code for both increments equal to 1 ! ! ! clean-up loop ! -20 m = mod (n, 5) - if (m.eq.0) goto 40 - do 30 i = 1, m +20 m = MOD (n, 5) + IF (m.eq.0) GOTO 40 + DO 30 i = 1, m dtemp = dtemp + dx (i) * dy (i) -30 end do - if (n.lt.5) goto 60 +30 END DO + IF (n.lt.5) GOTO 60 40 mp1 = m + 1 - do 50 i = mp1, n, 5 + DO 50 i = mp1, n, 5 dtemp = dtemp + dx (i) * dy (i) + dx (i + 1) * dy (i + 1) & + dx (i + 2) * dy (i + 2) + dx (i + 3) * dy (i + 3) + dx (i + & 4) * dy (i + 4) -50 end do +50 END DO 60 ddot = dtemp - return + RETURN -end function ddot +END FUNCTION ddot !====================== The end of ddot ================================ -subroutine dpofa (a, lda, n, info) - integer :: lda, n, info +SUBROUTINE dpofa (a, lda, n, info) + INTEGER :: lda, n, info doubleprecision a (lda, * ) ! ! dpofa factors a double precision symmetric positive definite @@ -4229,35 +4228,35 @@ subroutine dpofa (a, lda, n, info) ! doubleprecision ddot, t doubleprecision s - integer :: j, jm1, k + INTEGER :: j, jm1, k ! begin block with ...exits to 40 ! ! - do 30 j = 1, n + DO 30 j = 1, n info = j s = 0.0d0 jm1 = j - 1 - if (jm1.lt.1) goto 20 - do 10 k = 1, jm1 + IF (jm1.lt.1) GOTO 20 + DO 10 k = 1, jm1 t = a (k, j) - ddot (k - 1, a (1, k), 1, a (1, j), 1) t = t / a (k, k) a (k, j) = t s = s + t * t -10 end do -20 continue +10 END DO +20 CONTINUE s = a (j, j) - s ! ......exit - if (s.le.0.0d0) goto 40 - a (j, j) = sqrt (s) -30 end do + IF (s.le.0.0d0) GOTO 40 + a (j, j) = SQRT (s) +30 END DO info = 0 -40 continue - return +40 CONTINUE + RETURN -end subroutine dpofa +END SUBROUTINE dpofa !====================== The end of dpofa =============================== -subroutine dscal (n, da, dx, incx) +SUBROUTINE dscal (n, da, dx, incx) ! ! scales a vector by a constant. ! uses unrolled loops for increment equal to one. @@ -4265,45 +4264,45 @@ subroutine dscal (n, da, dx, incx) ! modified 3/93 to return if incx .le. 0. ! doubleprecision da, dx ( * ) - integer :: i, incx, m, mp1, n, nincx + INTEGER :: i, incx, m, mp1, n, nincx ! - if (n.le.0.or.incx.le.0) return - if (incx.eq.1) goto 20 + IF (n.le.0.or.incx.le.0) RETURN + IF (incx.eq.1) GOTO 20 ! ! code for increment not equal to 1 ! nincx = n * incx - do 10 i = 1, nincx, incx + DO 10 i = 1, nincx, incx dx (i) = da * dx (i) -10 end do - return +10 END DO + RETURN ! ! code for increment equal to 1 ! ! ! clean-up loop ! -20 m = mod (n, 5) - if (m.eq.0) goto 40 - do 30 i = 1, m +20 m = MOD (n, 5) + IF (m.eq.0) GOTO 40 + DO 30 i = 1, m dx (i) = da * dx (i) -30 end do - if (n.lt.5) return +30 END DO + IF (n.lt.5) RETURN 40 mp1 = m + 1 - do 50 i = mp1, n, 5 + DO 50 i = mp1, n, 5 dx (i) = da * dx (i) dx (i + 1) = da * dx (i + 1) dx (i + 2) = da * dx (i + 2) dx (i + 3) = da * dx (i + 3) dx (i + 4) = da * dx (i + 4) -50 end do - return +50 END DO + RETURN -end subroutine dscal +END SUBROUTINE dscal !====================== The end of dscal =============================== -subroutine dtrsl (t, ldt, n, b, job, info) - integer :: ldt, n, job, info +SUBROUTINE dtrsl (t, ldt, n, b, job, info) + INTEGER :: ldt, n, job, info doubleprecision t (ldt, * ), b ( * ) ! ! @@ -4363,84 +4362,84 @@ subroutine dtrsl (t, ldt, n, b, job, info) ! internal variables ! doubleprecision ddot, temp - integer :: case, j, jj + INTEGER :: CASE, j, jj ! ! begin block permitting ...exits to 150 ! ! check for zero diagonal elements. ! - do 10 info = 1, n + DO 10 info = 1, n ! ......exit - if (t (info, info) .eq.0.0d0) goto 150 -10 end do + IF (t (info, info) .eq.0.0d0) GOTO 150 +10 END DO info = 0 ! ! determine the task and go to it. ! - case = 1 - if (mod (job, 10) .ne.0) case = 2 - if (mod (job, 100) / 10.ne.0) case = case+2 - goto (20, 50, 80, 110), case + CASE = 1 + IF (MOD (job, 10) .ne.0) CASE = 2 + IF (MOD (job, 100) / 10.ne.0) CASE = CASE+2 + GOTO (20, 50, 80, 110), CASE ! ! solve t*x=b for t lower triangular ! -20 continue +20 CONTINUE b (1) = b (1) / t (1, 1) - if (n.lt.2) goto 40 - do 30 j = 2, n + IF (n.lt.2) GOTO 40 + DO 30 j = 2, n temp = - b (j - 1) - call daxpy (n - j + 1, temp, t (j, j - 1), 1, b (j), 1) + CALL daxpy (n - j + 1, temp, t (j, j - 1), 1, b (j), 1) b (j) = b (j) / t (j, j) -30 end do -40 continue - goto 140 +30 END DO +40 CONTINUE + GOTO 140 ! ! solve t*x=b for t upper triangular. ! -50 continue +50 CONTINUE b (n) = b (n) / t (n, n) - if (n.lt.2) goto 70 - do 60 jj = 2, n + IF (n.lt.2) GOTO 70 + DO 60 jj = 2, n j = n - jj + 1 temp = - b (j + 1) - call daxpy (j, temp, t (1, j + 1), 1, b (1), 1) + CALL daxpy (j, temp, t (1, j + 1), 1, b (1), 1) b (j) = b (j) / t (j, j) -60 end do -70 continue - goto 140 +60 END DO +70 CONTINUE + GOTO 140 ! ! solve trans(t)*x=b for t lower triangular. ! -80 continue +80 CONTINUE b (n) = b (n) / t (n, n) - if (n.lt.2) goto 100 - do 90 jj = 2, n + IF (n.lt.2) GOTO 100 + DO 90 jj = 2, n j = n - jj + 1 b (j) = b (j) - ddot (jj - 1, t (j + 1, j), 1, b (j + 1), & 1) b (j) = b (j) / t (j, j) -90 end do -100 continue - goto 140 +90 END DO +100 CONTINUE + GOTO 140 ! ! solve trans(t)*x=b for t upper triangular. ! -110 continue +110 CONTINUE b (1) = b (1) / t (1, 1) - if (n.lt.2) goto 130 - do 120 j = 2, n + IF (n.lt.2) GOTO 130 + DO 120 j = 2, n b (j) = b (j) - ddot (j - 1, t (1, j), 1, b (1), 1) b (j) = b (j) / t (j, j) -120 end do -130 continue -140 continue -150 continue - return +120 END DO +130 CONTINUE +140 CONTINUE +150 CONTINUE + RETURN -end subroutine dtrsl +END SUBROUTINE dtrsl !====================== The end of dtrsl =============================== -end module cp_lbfgs +END MODULE cp_lbfgs diff --git a/src/cp_lbfgs_optimizer_e_rosen.F b/src/cp_lbfgs_optimizer_e_rosen.F index 63ff3436c6..5bf802eb45 100644 --- a/src/cp_lbfgs_optimizer_e_rosen.F +++ b/src/cp_lbfgs_optimizer_e_rosen.F @@ -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 diff --git a/src/cp_lbfgs_optimizer_gerd_f.F b/src/cp_lbfgs_optimizer_gerd_f.F index 557f58101a..5063d5b607 100644 --- a/src/cp_lbfgs_optimizer_gerd_f.F +++ b/src/cp_lbfgs_optimizer_gerd_f.F @@ -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 diff --git a/src/cp_lbfgs_optimizer_tests.F b/src/cp_lbfgs_optimizer_tests.F index c59b5a787c..eec56d2133 100644 --- a/src/cp_lbfgs_optimizer_tests.F +++ b/src/cp_lbfgs_optimizer_tests.F @@ -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 diff --git a/src/cp_linked_list_int_ptr.F b/src/cp_linked_list_int_ptr.F index 11ec685877..5b96a597dd 100644 --- a/src/cp_linked_list_int_ptr.F +++ b/src/cp_linked_list_int_ptr.F @@ -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 diff --git a/src/cp_log_handling.F b/src/cp_log_handling.F index b9065a5d6a..1a5cf95600 100644 --- a/src/cp_log_handling.F +++ b/src/cp_log_handling.F @@ -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) diff --git a/src/cp_matrix_utils.F b/src/cp_matrix_utils.F index 739fca3976..c64009a60d 100644 --- a/src/cp_matrix_utils.F +++ b/src/cp_matrix_utils.F @@ -26,48 +26,64 @@ !! !! SOURCE !***************************************************************************** -module cp_matrix_utils - use cp_log_handling, only: cp_to_string, cp_note_level, cp_warning_level,& - cp_failure_level, cp_fatal_level, cp_logger_type - use cp_error_handling, only: cp_assert, cp_error_type, & - cp_error_dealloc_ref, cp_error_propagate_error, cp_debug,& - cp_assertion_failed, cp_error_message, cp_postcondition_failed,& - cp_error_init - use kinds, only: wp=>dp - use global_types, only: global_environment_type - use timings, only: timeset, timestop - use sparse_matrix_types, only: real_matrix_type, get_matrix_info,& - first_block_node, add_block_node, get_block_node, & - find_block_node, real_block_node_type, next_block_node,& - copy_sparse_to_full_matrix - use message_passing, only: mp_sum - use cp_b_matrix_structure, only: cp_b_matrix_struct_type,& - cp_b_distribution_type - use cp_array_utils, only: cp_2d_i_guarantee_size, & - cp_2d_logical_guarantee_size, cp_2d_r_output - use mathlib, only: symmetrize_matrix - use cp_output_handling, only: cp_would_output - use cp_para_types, only: cp_para_env_type +MODULE cp_matrix_utils !use qs_blacs, only: - implicit none - private + USE cp_array_utils, ONLY: cp_2d_i_guarantee_size,& + cp_2d_logical_guarantee_size,& + cp_2d_r_output + USE cp_b_matrix_structure, ONLY: cp_b_distribution_type,& + cp_b_matrix_struct_type + USE cp_error_handling, ONLY: cp_assert,& + cp_assertion_failed,& + cp_debug,& + cp_error_dealloc_ref,& + cp_error_init,& + cp_error_message,& + cp_error_propagate_error,& + cp_error_type,& + cp_postcondition_failed + USE cp_log_handling, ONLY: cp_failure_level,& + cp_fatal_level,& + cp_logger_type,& + cp_note_level,& + cp_to_string,& + cp_warning_level + USE cp_output_handling, ONLY: cp_would_output + USE cp_para_types, ONLY: cp_para_env_type + USE global_types, ONLY: global_environment_type + USE kinds, ONLY: wp=>dp + USE mathlib, ONLY: symmetrize_matrix + USE message_passing, ONLY: mp_sum + USE sparse_matrix_types, ONLY: add_block_node,& + copy_sparse_to_full_matrix,& + find_block_node,& + first_block_node,& + get_block_node,& + get_matrix_info,& + next_block_node,& + real_block_node_type,& + real_matrix_type + USE timings, ONLY: timeset,& + timestop + IMPLICIT NONE + PRIVATE - logical, private, parameter :: debug_this_module=.true. - character(len=*), private, parameter :: moduleN='cp_matrix_utils' + LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. + CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='cp_matrix_utils' ! types - public :: cp_matrix_block_iterator + PUBLIC :: cp_matrix_block_iterator ! core methods - public :: cp_init, cp_dealloc_ref, cp_get, cp_next, cp_valid + PUBLIC :: cp_init, cp_dealloc_ref, cp_get, cp_next, cp_valid - public :: cp_trace + PUBLIC :: cp_trace - public :: cp_p_norm_matrix, cp_sup_norm_matrix,& + PUBLIC :: cp_p_norm_matrix, cp_sup_norm_matrix,& cp_is_block_diagonal, cp_init_diagonal_blocks,& cp_d_struct_create, cp_set_to ! underliying methods (try to use the generic interface) - public :: cp_sm_diag_trace, cp_sm_set_to, cp_sm_b_i_init,& + PUBLIC :: cp_sm_diag_trace, cp_sm_set_to, cp_sm_b_i_init,& cp_sm_b_i_dealloc_ref, cp_sm_b_i_get, & cp_sm_b_i_next, cp_sm_b_i_valid, & cp_sm_is_block_diagonal, cp_sm_init_diagonal_blocks,& @@ -75,51 +91,51 @@ module cp_matrix_utils cp_sm_output ! return the trace of the given matrices - interface cp_trace - module procedure cp_sm_diag_trace - end interface + INTERFACE cp_trace + MODULE PROCEDURE cp_sm_diag_trace + END INTERFACE !! set all the values to a given value - interface cp_set_to - module procedure cp_sm_set_to - end interface + INTERFACE cp_set_to + MODULE PROCEDURE cp_sm_set_to + END INTERFACE ! = core methods = !! initializes the object - interface cp_init - module procedure cp_sm_b_i_init - end interface + INTERFACE cp_init + MODULE PROCEDURE cp_sm_b_i_init + END INTERFACE !! deallocates the memory allocated by the object - interface cp_dealloc_ref - module procedure cp_sm_b_i_dealloc_ref - end interface + INTERFACE cp_dealloc_ref + MODULE PROCEDURE cp_sm_b_i_dealloc_ref + END INTERFACE !! gets various attributes from the object - interface cp_get - module procedure cp_sm_b_i_get - end interface + INTERFACE cp_get + MODULE PROCEDURE cp_sm_b_i_get + END INTERFACE !! goes to the next element, returns true if valid - interface cp_next - module procedure cp_sm_b_i_next - end interface + INTERFACE cp_next + MODULE PROCEDURE cp_sm_b_i_next + END INTERFACE !! return true if it is valid (minimal testing) - interface cp_valid - module procedure cp_sm_b_i_valid - end interface + INTERFACE cp_valid + MODULE PROCEDURE cp_sm_b_i_valid + END INTERFACE !! returns true if the matrix is block diagonal - interface cp_is_block_diagonal - module procedure cp_sm_is_block_diagonal - end interface + INTERFACE cp_is_block_diagonal + MODULE PROCEDURE cp_sm_is_block_diagonal + END INTERFACE !! initializes the diagonal matrix blocks - interface cp_init_diagonal_blocks - module procedure cp_sm_init_diagonal_blocks - end interface + INTERFACE cp_init_diagonal_blocks + MODULE PROCEDURE cp_sm_init_diagonal_blocks + END INTERFACE !!*** !**************************************************************************** @@ -151,17 +167,17 @@ module cp_matrix_utils !! !! SOURCE !*************************************************************************** - type cp_matrix_block_iterator - private - logical :: initialized - type(real_matrix_type), pointer :: matrix - integer :: block_row - type(real_block_node_type), pointer :: block_node - end type cp_matrix_block_iterator + TYPE cp_matrix_block_iterator + PRIVATE + LOGICAL :: initialized + TYPE(real_matrix_type), POINTER :: matrix + INTEGER :: block_row + TYPE(real_block_node_type), POINTER :: block_node + END TYPE cp_matrix_block_iterator !!*** !**************************************************************************** -contains +CONTAINS ! ============== real full matrix utilities ============ !!****f* cp_matrix_utils/cp_p_norm_matrix [1.0] * @@ -200,28 +216,28 @@ contains !! !!*** ********************************************************************** !pure - function cp_p_norm_matrix(matrix, p) result(res) - real(kind=wp) :: res - real(kind=wp), intent(in), dimension(:,:) :: matrix - integer,optional, intent(in) :: p + FUNCTION cp_p_norm_matrix(matrix, p) RESULT(res) + REAL(kind=wp) :: res + REAL(kind=wp), INTENT(in), DIMENSION(:,:) :: matrix + INTEGER,OPTIONAL, INTENT(in) :: p !type(cp_error_type), optional, intent(inout) :: error ! removed to make it pure - logical :: failure - character(len=*), parameter :: routineP='cp_matrix_utils:cp_froebnius_norm2' - integer :: i,j, pVal + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='cp_matrix_utils:cp_froebnius_norm2' + INTEGER :: i,j, pVal failure=.FALSE. res=0 - if (.NOT. failure) then + IF (.NOT. failure) THEN pVal=2 - if (.not. present(p)) pVal=p - do i=1,size(matrix,1) - do j=1,size(matrix,2) + IF (.NOT. PRESENT(p)) pVal=p + DO i=1,SIZE(matrix,1) + DO j=1,SIZE(matrix,2) res=res+matrix(i,j)**pVal - end do - end do - end if - end function cp_p_norm_matrix + END DO + END DO + END IF + END FUNCTION cp_p_norm_matrix !*************************************************************************** !!****f* cp_matrix_utils/cp_sup_norm_matrix [1.0] * @@ -256,21 +272,21 @@ contains !! !!*** ********************************************************************** !pure - function cp_sup_norm_matrix(matrix) result(res) - real(kind=wp) :: res - real(kind=wp), dimension(:,:), intent(in) :: matrix + FUNCTION cp_sup_norm_matrix(matrix) RESULT(res) + REAL(kind=wp) :: res + REAL(kind=wp), DIMENSION(:,:), INTENT(in) :: matrix !type(cp_error_type), optional, intent(inout) :: error ! removed to make it pure - logical :: failure - character(len=*), parameter :: routineP='cp_matrix_utils:cp_sup_norm_matrix' + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='cp_matrix_utils:cp_sup_norm_matrix' failure=.FALSE. - if (.NOT. failure) then - res=maxval(abs(matrix)) - else + IF (.NOT. failure) THEN + res=MAXVAL(ABS(matrix)) + ELSE res=-1.0_wp - end if - end function cp_sup_norm_matrix + END IF + END FUNCTION cp_sup_norm_matrix !*************************************************************************** ! ================== cp_matrix_block_iterator ================ @@ -312,28 +328,28 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_sm_b_i_init(block_iterator, matrix, block_row,& + SUBROUTINE cp_sm_b_i_init(block_iterator, matrix, block_row,& block_node, error) - type(cp_matrix_block_iterator), intent(out) :: block_iterator - type(real_matrix_type), target, intent(in) :: matrix + TYPE(cp_matrix_block_iterator), INTENT(out) :: block_iterator + TYPE(real_matrix_type), TARGET, INTENT(in) :: matrix ! well subsequent operations on the iterator could change tha data in the matrix - integer, intent(in), optional :: block_row - type(real_block_node_type), target, optional :: block_node - type(cp_error_type), optional, intent(inout) :: error + INTEGER, INTENT(in), OPTIONAL :: block_row + TYPE(real_block_node_type), TARGET, OPTIONAL :: block_node + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='cp_matrix_utils:cp_sm_b_i_init' - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='cp_matrix_utils:cp_sm_b_i_init' + failure=.FALSE. block_iterator%matrix => matrix block_iterator%block_row = 1 - nullify(block_iterator%block_node) - block_iterator%initialized=.true. - if (present(block_node)) & + NULLIFY(block_iterator%block_node) + block_iterator%initialized=.TRUE. + IF (PRESENT(block_node)) & block_iterator%block_node => block_node - if (present(block_row)) & + IF (PRESENT(block_row)) & block_iterator%block_row = block_row - end subroutine cp_sm_b_i_init + END SUBROUTINE cp_sm_b_i_init !*************************************************************************** !!****f* cp_matrix_utils/cp_sm_b_i_dealloc_ref [1.0] * @@ -366,20 +382,20 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_sm_b_i_dealloc_ref(block_iterator, error) - type(cp_matrix_block_iterator), intent(inout) :: block_iterator - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sm_b_i_dealloc_ref(block_iterator, error) + TYPE(cp_matrix_block_iterator), INTENT(inout) :: block_iterator + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='cp_matrix_utils:cp_sm_b_i_dealloc_ref' - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='cp_matrix_utils:cp_sm_b_i_dealloc_ref' + failure=.FALSE. CPPrecondition(block_iterator%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - nullify(block_iterator%matrix, block_iterator%block_node) + IF (.NOT. failure) THEN + NULLIFY(block_iterator%matrix, block_iterator%block_node) block_iterator%block_row=0 - end if - end subroutine cp_sm_b_i_dealloc_ref + END IF + END SUBROUTINE cp_sm_b_i_dealloc_ref !*************************************************************************** !!****f* cp_matrix_utils/cp_sm_b_i_get [1.0] * @@ -425,52 +441,52 @@ contains !! none !! !!*** ********************************************************************** - subroutine cp_sm_b_i_get(block_iterator, block_row, block_col,& + SUBROUTINE cp_sm_b_i_get(block_iterator, block_row, block_col,& block_val, finished, matrix, block_node, error) - type(cp_matrix_block_iterator), intent(in) :: block_iterator - integer, optional, intent(out) :: block_row, block_col - real(kind=wp), dimension(:,:), pointer, optional :: block_val - logical, optional, intent(out) :: finished - type(real_matrix_type), optional, pointer :: matrix - type(real_block_node_type), optional, pointer :: block_node - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_matrix_block_iterator), INTENT(in) :: block_iterator + INTEGER, OPTIONAL, INTENT(out) :: block_row, block_col + REAL(kind=wp), DIMENSION(:,:), POINTER, OPTIONAL :: block_val + LOGICAL, OPTIONAL, INTENT(out) :: finished + TYPE(real_matrix_type), OPTIONAL, POINTER :: matrix + TYPE(real_block_node_type), OPTIONAL, POINTER :: block_node + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='cp_matrix_utils:cp_sm_b_i_get' - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='cp_matrix_utils:cp_sm_b_i_get' + failure=.FALSE. CPPrecondition(block_iterator%initialized,cp_failure_level,routineP,error,failure) - CPPrecondition(associated(block_iterator%matrix),cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (present(block_row)) & + CPPrecondition(ASSOCIATED(block_iterator%matrix),cp_failure_level,routineP,error,failure) + IF (.NOT. failure) THEN + IF (PRESENT(block_row)) & block_row=block_iterator%block_row - if (present(block_col)) then - if (associated(block_iterator%block_node)) then - call get_block_node(block_iterator%block_node, block_col=block_col) - else - CPAssert(.false.,cp_warning_level,routineP,error,failure) + IF (PRESENT(block_col)) THEN + IF (ASSOCIATED(block_iterator%block_node)) THEN + CALL get_block_node(block_iterator%block_node, block_col=block_col) + ELSE + CPAssert(.FALSE.,cp_warning_level,routineP,error,failure) block_col=-1 - end if - end if - if (present(block_val)) then + END IF + END IF + IF (PRESENT(block_val)) THEN CPPrecondition(block_iterator%block_row>0,cp_failure_level,routineP,error,failure) - if (.not.failure) then - if (associated(block_iterator%block_node)) then - call get_block_node(block_iterator%block_node,block=block_val) - else - nullify(block_val) - CPErrorMessage(cp_failure_level,routineP,"invalid block",error) - end if - end if - end if - if (present(finished)) & + IF (.not.failure) THEN + IF (ASSOCIATED(block_iterator%block_node)) THEN + CALL get_block_node(block_iterator%block_node,BLOCK=block_val) + ELSE + NULLIFY(block_val) + CPErrorMessage(cp_failure_level,routineP,"invalid BLOCK",error) + END IF + END IF + END IF + IF (PRESENT(finished)) & finished = block_iterator%block_row <= 0 - if (present(matrix)) & + IF (PRESENT(matrix)) & matrix => block_iterator%matrix - if (present(block_node)) & + IF (PRESENT(block_node)) & block_node => block_iterator%block_node - end if - end subroutine cp_sm_b_i_get + END IF + END SUBROUTINE cp_sm_b_i_get !*************************************************************************** !!****f* cp_matrix_utils/cp_sm_b_i_valid [1.0] * @@ -505,24 +521,24 @@ contains !! none !! !!*** ********************************************************************** - function cp_sm_b_i_valid(block_iterator,error) result(res) - logical ::res - type(cp_matrix_block_iterator), intent(in) :: block_iterator - type(cp_error_type), optional, intent(inout) :: error + FUNCTION cp_sm_b_i_valid(block_iterator,error) RESULT(res) + LOGICAL ::res + TYPE(cp_matrix_block_iterator), INTENT(in) :: block_iterator + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='cp_matrix_utils:cp_sm_b_i_valid' - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='cp_matrix_utils:cp_sm_b_i_valid' + failure=.FALSE. CPPrecondition(block_iterator%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (.not.(associated(block_iterator%matrix).and. block_iterator%block_row>0 ))then + IF (.NOT. failure) THEN + IF (.NOT.(ASSOCIATED(block_iterator%matrix).AND. block_iterator%block_row>0 ))THEN CPAssert(block_iterator%block_row > 0,cp_warning_level,routineP,error,failure) - CPAssert(associated(block_iterator%matrix),cp_warning_level,routineP,error,failure) - end if - end if + CPAssert(ASSOCIATED(block_iterator%matrix),cp_warning_level,routineP,error,failure) + END IF + END IF res=.not.failure - end function cp_sm_b_i_valid + END FUNCTION cp_sm_b_i_valid !*************************************************************************** !!****f* cp_matrix_utils/cp_sm_b_i_next [1.0] * @@ -566,66 +582,66 @@ contains !! none !! !!*** ********************************************************************** - function cp_sm_b_i_next(block_iterator, block_row, block_col,& - block_val, finished, matrix, block_node, error)result(res) - type(cp_matrix_block_iterator), intent(inout) :: block_iterator - integer, optional, intent(out) :: block_row, block_col - real(kind=wp), dimension(:,:), pointer, optional :: block_val - logical, optional, intent(out) :: finished - type(real_matrix_type), optional, pointer :: matrix - type(real_block_node_type), optional, pointer :: block_node - type(cp_error_type), optional, intent(inout) :: error - logical :: res + FUNCTION cp_sm_b_i_next(block_iterator, block_row, block_col,& + block_val, finished, matrix, block_node, error)RESULT(res) + TYPE(cp_matrix_block_iterator), INTENT(inout) :: block_iterator + INTEGER, OPTIONAL, INTENT(out) :: block_row, block_col + REAL(kind=wp), DIMENSION(:,:), POINTER, OPTIONAL :: block_val + LOGICAL, OPTIONAL, INTENT(out) :: finished + TYPE(real_matrix_type), OPTIONAL, POINTER :: matrix + TYPE(real_block_node_type), OPTIONAL, POINTER :: block_node + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error + LOGICAL :: res - logical :: failure - character(len=*), parameter :: routineP='cp_matrix_utils:cp_sm_b_i_next' - integer :: nblock_row,i - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='cp_matrix_utils:cp_sm_b_i_next' + INTEGER :: nblock_row,i + failure=.FALSE. CPPrecondition(block_iterator%initialized,cp_failure_level,routineP,error,failure) - CPPrecondition(associated(block_iterator%matrix),cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (block_iterator%block_row > 0) then - if (associated(block_iterator%block_node)) then + CPPrecondition(ASSOCIATED(block_iterator%matrix),cp_failure_level,routineP,error,failure) + IF (.NOT. failure) THEN + IF (block_iterator%block_row > 0) THEN + IF (ASSOCIATED(block_iterator%block_node)) THEN block_iterator%block_node => next_block_node(block_iterator%block_node) - if (.not.associated(block_iterator%block_node)) then + IF (.not.ASSOCIATED(block_iterator%block_node)) THEN block_iterator%block_row= block_iterator%block_row+1 - end if - end if - if (.not.associated(block_iterator%block_node)) then - call get_matrix_info(block_iterator%matrix,nblock_row=nblock_row) - do i=block_iterator%block_row,nblock_row + END IF + END IF + IF (.not.ASSOCIATED(block_iterator%block_node)) THEN + CALL get_matrix_info(block_iterator%matrix,nblock_row=nblock_row) + DO i=block_iterator%block_row,nblock_row block_iterator%block_node => & first_block_node(block_iterator%matrix,& block_iterator%block_row) - if (associated(block_iterator%block_node)) then + IF (ASSOCIATED(block_iterator%block_node)) THEN block_iterator%block_row=i - exit - end if - end do - end if - if (.not.associated(block_iterator%block_node)) then + EXIT + END IF + END DO + END IF + IF (.not.ASSOCIATED(block_iterator%block_node)) THEN block_iterator%block_row=-1 - else - res=.true. - call cp_sm_b_i_get(block_iterator, block_row=block_row,& + ELSE + res=.TRUE. + CALL cp_sm_b_i_get(block_iterator, block_row=block_row,& block_col=block_col, block_val=block_val,& finished=finished, matrix=matrix, block_node=block_node,& error=error) - return - end if - end if - CPPostcondition(.not.associated(block_iterator%block_node),cp_warning_level,routineP,error,failure) - if (.not. block_iterator%block_row <= 0) then + RETURN + END IF + END IF + CPPostcondition(.not.ASSOCIATED(block_iterator%block_node),cp_warning_level,routineP,error,failure) + IF (.NOT. block_iterator%block_row <= 0) THEN CPErrorMessage(cp_warning_level,routineP,"inconsistent state in iterator",error) block_iterator%block_row=-2 - end if - else + END IF + ELSE block_iterator%block_row=-2 - nullify(block_iterator%block_node) - end if - res=.false. - end function cp_sm_b_i_next + NULLIFY(block_iterator%block_node) + END IF + res=.FALSE. + END FUNCTION cp_sm_b_i_next !*************************************************************************** ! ============ real block (sparse) matrix utils =========== @@ -666,43 +682,43 @@ contains !! none !! !!*** ********************************************************************** -function cp_sm_diag_trace(diagonal, matrix, para_env, error) result(res) - real(kind=wp) :: res - real(kind=wp), dimension(:), intent(in) :: diagonal - type(real_matrix_type), intent(in), target :: matrix - type(cp_para_env_type), pointer :: para_env - type(cp_error_type), optional, intent(inout) :: error +FUNCTION cp_sm_diag_trace(diagonal, matrix, para_env, error) RESULT(res) + REAL(kind=wp) :: res + REAL(kind=wp), DIMENSION(:), INTENT(in) :: diagonal + TYPE(real_matrix_type), INTENT(in), TARGET :: matrix + TYPE(cp_para_env_type), POINTER :: para_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: handle, i, j - character(len=*), parameter :: routineN='cp_sm_diag_trace',& + LOGICAL :: failure + INTEGER :: handle, i, j + CHARACTER(len=*), PARAMETER :: routineN='cp_sm_diag_trace',& routineP=moduleN//':'//routineN - type(cp_matrix_block_iterator) :: iterator - real(kind=wp), dimension(:,:), pointer :: block_val - integer, dimension(:), pointer :: first_row,first_col - type(real_matrix_type), pointer :: matrix_ptr - failure=.false. + TYPE(cp_matrix_block_iterator) :: iterator + REAL(kind=wp), DIMENSION(:,:), POINTER :: block_val + INTEGER, DIMENSION(:), POINTER :: first_row,first_col + TYPE(real_matrix_type), POINTER :: matrix_ptr + failure=.FALSE. matrix_ptr => matrix - call timeset(routineN//','//moduleN,'I',"",handle) - call cp_init(iterator, matrix=matrix) - call get_matrix_info(matrix_ptr, first_row=first_row, first_col=first_col) + CALL timeset(routineN//','//moduleN,'I',"",handle) + CALL cp_init(iterator, matrix=matrix) + CALL get_matrix_info(matrix_ptr, first_row=first_row, first_col=first_col) res=0.0_wp - do - if (.not.cp_next(iterator,error=error)) exit - call cp_get(iterator, block_row=i,block_col=j, block_val=block_val,& + DO + IF (.not.cp_next(iterator,error=error)) EXIT + CALL cp_get(iterator, block_row=i,block_col=j, block_val=block_val,& error=error) - if (i==j) then - CPPrecondition(size(block_val,1)==size(block_val,2),cp_failure_level,routineP,error,failure) + IF (i==j) THEN + CPPrecondition(SIZE(block_val,1)==SIZE(block_val,2),cp_failure_level,routineP,error,failure) CPPrecondition(first_col(i)==first_row(i),cp_failure_level,routineP,error,failure) - do i=1,min(size(block_val,1),size(block_val,2)) + DO i=1,MIN(SIZE(block_val,1),SIZE(block_val,2)) res=res+block_val(i,i)+diagonal(first_col(i)+i) - end do - end if - end do - call mp_sum(res,para_env%group) - call timestop(0.0_wp,handle) -end function cp_sm_diag_trace + END DO + END IF + END DO + CALL mp_sum(res,para_env%group) + CALL timestop(0.0_wp,handle) +END FUNCTION cp_sm_diag_trace !*************************************************************************** !!****f* cp_matrix_utils/cp_sm_set_to [1.0] * @@ -742,52 +758,52 @@ end function cp_sm_diag_trace !! none !! !!*** ********************************************************************** - subroutine cp_sm_set_to(matrix, value, error) - type(real_matrix_type), intent(inout), target :: matrix - real(kind=wp), optional, intent(in) :: value - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE cp_sm_set_to(matrix, value, error) + TYPE(real_matrix_type), INTENT(inout), TARGET :: matrix + REAL(kind=wp), OPTIONAL, INTENT(in) :: value + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='cp_matrix_utils:cp_sm_set_to' - type(cp_matrix_block_iterator) :: iterator - real(kind=wp), dimension(:,:), pointer :: block_val - real(kind=wp) :: val - type(cp_error_type) :: iError - failure=.false. - call cp_error_init(iError,template_error=error) + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='cp_matrix_utils:cp_sm_set_to' + TYPE(cp_matrix_block_iterator) :: iterator + REAL(kind=wp), DIMENSION(:,:), POINTER :: block_val + REAL(kind=wp) :: val + TYPE(cp_error_type) :: iError + failure=.FALSE. + CALL cp_error_init(iError,template_error=error) val=0.0_wp - if (.not. failure) then - call cp_init(iterator,matrix,error=iError) - call cp_error_propagate_error(iError,routineP,& + IF (.NOT. failure) THEN + CALL cp_init(iterator,matrix,error=iError) + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure) - end if - if (.not.failure) then - if (present(value)) val=value - do - if (cp_next(iterator,error=iError)) then - call cp_get(iterator,block_val=block_val,error=iError) - call cp_error_propagate_error(iError,routineP,& + END IF + IF (.not.failure) THEN + IF (PRESENT(value)) val=value + DO + IF (cp_next(iterator,error=iError)) THEN + CALL cp_get(iterator,block_val=block_val,error=iError) + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure) - CPPrecondition(associated(block_val),cp_failure_level,routineP,error,failure) - if (.not.failure) then + CPPrecondition(ASSOCIATED(block_val),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN block_val=val - else - exit - end if - else - call cp_error_propagate_error(iError,routineP,& + ELSE + EXIT + END IF + ELSE + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure) - exit - end if - end do - call cp_dealloc_ref(iterator,error=error) - end if - call cp_error_dealloc_ref(iError,error=error) - end subroutine cp_sm_set_to + EXIT + END IF + END DO + CALL cp_dealloc_ref(iterator,error=error) + END IF + CALL cp_error_dealloc_ref(iError,error=error) + END SUBROUTINE cp_sm_set_to !*************************************************************************** !!****f* cp_matrix_utils/cp_build_d_struct [1.0] * @@ -821,69 +837,69 @@ end function cp_sm_diag_trace !! none !! !!*** ********************************************************************** -subroutine cp_d_struct_create(d_struct, matrix, n_blocks, para_env, error) - integer, dimension(:), pointer :: d_struct - type(cp_para_env_type), pointer :: para_env - type(real_matrix_type), intent(in), target, optional :: matrix - integer, optional, intent(in) :: n_blocks - type(cp_error_type), optional, intent(inout) :: error +SUBROUTINE cp_d_struct_create(d_struct, matrix, n_blocks, para_env, error) + INTEGER, DIMENSION(:), POINTER :: d_struct + TYPE(cp_para_env_type), POINTER :: para_env + TYPE(real_matrix_type), INTENT(in), TARGET, OPTIONAL :: matrix + INTEGER, OPTIONAL, INTENT(in) :: n_blocks + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: handle, i, j, nrows, ncols, stat, rest, nmin - character(len=*), parameter :: routineN='cp_build_d_struct',& + LOGICAL :: failure + INTEGER :: handle, i, j, nrows, ncols, stat, rest, nmin + CHARACTER(len=*), PARAMETER :: routineN='cp_build_d_struct',& routineP=moduleN//':'//routineN - type(cp_matrix_block_iterator) :: iterator - type(real_matrix_type), pointer :: matrix_ptr - failure=.false. + TYPE(cp_matrix_block_iterator) :: iterator + TYPE(real_matrix_type), POINTER :: matrix_ptr + failure=.FALSE. !call timeset(routineN//','//moduleN,'I',"",handle) - if (present(matrix)) then + IF (PRESENT(matrix)) THEN matrix_ptr => matrix - call get_matrix_info(matrix_ptr, nblock_row=nrows, nblock_col=ncols) + CALL get_matrix_info(matrix_ptr, nblock_row=nrows, nblock_col=ncols) CPAssert(ncols==nrows,cp_warning_level,routineP,error,failure) - ncols=min(nrows,ncols) - if (present(n_blocks)) then + ncols=MIN(nrows,ncols) + IF (PRESENT(n_blocks)) THEN CPPrecondition(ncols==n_blocks,cp_warning_level,routineP,error,failure) - end if - if (.not.failure) then + END IF + IF (.not.failure) THEN ! assume every diagonal block is on one (and just one) proc - allocate(d_struct(ncols),stat=stat) + ALLOCATE(d_struct(ncols),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) d_struct=0 - call cp_init(iterator, matrix=matrix_ptr, error=error) - do - if (.not.cp_next(iterator)) exit - call cp_get(iterator,block_row=i,block_col=j,error=error) - if (i==j) then + CALL cp_init(iterator, matrix=matrix_ptr, error=error) + DO + IF (.not.cp_next(iterator)) EXIT + CALL cp_get(iterator,block_row=i,block_col=j,error=error) + IF (i==j) THEN d_struct(i)=para_env%mepos - end if - end do - call cp_dealloc_ref(iterator,error=error) - call mp_sum(d_struct,para_env%group) - end if - else - CPPrecondition(present(n_blocks),cp_failure_level,routineP,error,failure) - if (.not.failure) then - allocate(d_struct(n_blocks),stat=stat) + END IF + END DO + CALL cp_dealloc_ref(iterator,error=error) + CALL mp_sum(d_struct,para_env%group) + END IF + ELSE + CPPrecondition(PRESENT(n_blocks),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN + ALLOCATE(d_struct(n_blocks),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then + END IF + IF (.not.failure) THEN nmin= n_blocks/para_env%num_pe - rest=mod(n_blocks,para_env%num_pe) - do j=0,(rest-1) - do i=1,nmin+1 + rest=MOD(n_blocks,para_env%num_pe) + DO j=0,(rest-1) + DO i=1,nmin+1 d_struct(j*(nmin+1)+i)=j - end do - end do - do j=rest,(para_env%num_pe-1) - do i=1,nmin+1 + END DO + END DO + DO j=rest,(para_env%num_pe-1) + DO i=1,nmin+1 d_struct(rest+j*nmin+i)=j - end do - end do - end if - end if + END DO + END DO + END IF + END IF !call timestop(0.0_wp,handle) -end subroutine cp_d_struct_create +END SUBROUTINE cp_d_struct_create !*************************************************************************** @@ -927,74 +943,74 @@ end subroutine cp_d_struct_create !! none !! !!*** ********************************************************************** - subroutine cp_sm_init_diagonal_blocks(matrix, para_env, d_struct, & + SUBROUTINE cp_sm_init_diagonal_blocks(matrix, para_env, d_struct, & default_value, diagonal_value, error) - type(real_matrix_type), intent(inout), target :: matrix - type(cp_para_env_type), pointer :: para_env - integer, optional, dimension(:), intent(in), target :: d_struct - real(kind=wp), intent(in), optional :: default_value, diagonal_value - type(cp_error_type), optional, intent(inout) :: error + TYPE(real_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_para_env_type), POINTER :: para_env + INTEGER, OPTIONAL, DIMENSION(:), INTENT(in), TARGET :: d_struct + REAL(kind=wp), INTENT(in), OPTIONAL :: default_value, diagonal_value + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: handle, i, j, nrows, ncols, rest, nblocks, stat - integer, pointer, dimension(:) :: my_d_struct - type(real_block_node_type), pointer :: m_block - real(kind=wp), dimension(:,:), pointer :: block_val - character(len=*), parameter :: routineN='cp_sm_init_diagonal_blocks',& + LOGICAL :: failure + INTEGER :: handle, i, j, nrows, ncols, rest, nblocks, stat + INTEGER, POINTER, DIMENSION(:) :: my_d_struct + TYPE(real_block_node_type), POINTER :: m_block + REAL(kind=wp), DIMENSION(:,:), POINTER :: block_val + CHARACTER(len=*), PARAMETER :: routineN='cp_sm_init_diagonal_blocks',& routineP=moduleN//':'//routineN - type(real_matrix_type), pointer :: matrix_ptr + TYPE(real_matrix_type), POINTER :: matrix_ptr matrix_ptr => matrix - failure=.false. + failure=.FALSE. - CPPrecondition(associated(matrix_ptr),cp_failure_level,routineP,error,failure) - call timeset(routineN//','//moduleN,'I',"",handle) - if (.not.failure) then - call get_matrix_info(matrix_ptr, nblock_row=nrows, nblock_col=ncols) + CPPrecondition(ASSOCIATED(matrix_ptr),cp_failure_level,routineP,error,failure) + CALL timeset(routineN//','//moduleN,'I',"",handle) + IF (.not.failure) THEN + CALL get_matrix_info(matrix_ptr, nblock_row=nrows, nblock_col=ncols) CPPreconditionNoFail(nrows==ncols,cp_warning_level,routineP,error) - ncols=min(ncols,nrows) - if (present(d_struct)) then - CPPrecondition(ncols==size(d_struct),cp_failure_level,routineP,error,failure) + ncols=MIN(ncols,nrows) + IF (PRESENT(d_struct)) THEN + CPPrecondition(ncols==SIZE(d_struct),cp_failure_level,routineP,error,failure) my_d_struct => d_struct - else - call cp_d_struct_create(my_d_struct, n_blocks=ncols, & + ELSE + CALL cp_d_struct_create(my_d_struct, n_blocks=ncols, & para_env=para_env, error=error) - end if - CPPostcondition(associated(my_d_struct),cp_failure_level,routineP,error,failure) - if (.not.failure) then - do i=1,size(my_d_struct) - if (para_env%mepos==my_d_struct(i)) then + END IF + CPPostcondition(ASSOCIATED(my_d_struct),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN + DO i=1,SIZE(my_d_struct) + IF (para_env%mepos==my_d_struct(i)) THEN m_block => find_block_node(matrix_ptr,i,i) - nullify(block_val) - if (.not.associated(m_block)) then - call add_block_node(matrix_ptr,i,i,block_val) - else - call get_block_node(m_block,block=block_val) - end if - if (present(default_value)) block_val=default_value - if (present(diagonal_value)) then - forall (j=1:min(size(block_val,1),size(block_val,2))) + NULLIFY(block_val) + IF (.not.ASSOCIATED(m_block)) THEN + CALL add_block_node(matrix_ptr,i,i,block_val) + ELSE + CALL get_block_node(m_block,BLOCK=block_val) + END IF + IF (PRESENT(default_value)) block_val=default_value + IF (PRESENT(diagonal_value)) THEN + FORALL (j=1:MIN(SIZE(block_val,1),SIZE(block_val,2))) block_val(j,j)=diagonal_value - end forall - end if - else + END FORALL + END IF + ELSE m_block => find_block_node(matrix_ptr,i,i) - if (associated(m_block)) then - CPErrorMessage(cp_failure_level,routineP,"diag block on wrong processor",error) + IF (ASSOCIATED(m_block)) THEN + CPErrorMessage(cp_failure_level,routineP,"diag BLOCK on wrong processor",error) ! call remove_real_block_node(matrix_ptr,i,i) ! to do - end if - end if - end do - end if - if (cp_debug.and.debug_this_module) then ! test if diag - call cp_assert(cp_is_block_diagonal(matrix,para_env),& + END IF + END IF + END DO + END IF + IF (cp_debug.and.debug_this_module) THEN ! test if diag + CALL cp_assert(cp_is_block_diagonal(matrix,para_env),& cp_failure_level,& cp_assertion_failed,routineP, "matrix is not diagonal in "//& CPSourceFileRef,& error,failure) - end if - end if - call timestop(0.0_wp,handle) -end subroutine cp_sm_init_diagonal_blocks + END IF + END IF + CALL timestop(0.0_wp,handle) +END SUBROUTINE cp_sm_init_diagonal_blocks !*************************************************************************** !!****f* cp_matrix_utils/cp_sm_is_block_diagonal [1.0] * @@ -1030,59 +1046,59 @@ end subroutine cp_sm_init_diagonal_blocks !! none !! !!*** ********************************************************************** -function cp_sm_is_block_diagonal(matrix, para_env, error) result(res) - logical :: res - type(real_matrix_type), intent(inout), target :: matrix - type(cp_para_env_type), pointer :: para_env - type(cp_error_type), optional, intent(inout) :: error +FUNCTION cp_sm_is_block_diagonal(matrix, para_env, error) RESULT(res) + LOGICAL :: res + TYPE(real_matrix_type), INTENT(inout), TARGET :: matrix + TYPE(cp_para_env_type), POINTER :: para_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer, dimension(:), allocatable :: myDiag - integer :: handle, i,j, nrows,ncols, stat - character(len=*), parameter :: routineN='cp_sm_is_block_diagonal',& + LOGICAL :: failure + INTEGER, DIMENSION(:), ALLOCATABLE :: myDiag + INTEGER :: handle, i,j, nrows,ncols, stat + CHARACTER(len=*), PARAMETER :: routineN='cp_sm_is_block_diagonal',& routineP=moduleN//':'//routineN - type(cp_matrix_block_iterator) :: iterator - type(real_matrix_type), pointer :: matrix_ptr - failure=.false. + TYPE(cp_matrix_block_iterator) :: iterator + TYPE(real_matrix_type), POINTER :: matrix_ptr + failure=.FALSE. matrix_ptr => matrix !call timeset(routineN//','//moduleN,'I',"",handle) - CPPrecondition(associated(matrix_ptr),cp_failure_level,routineP,error,failure) - if (.not. failure) then - call get_matrix_info(matrix_ptr, nblock_row=nrows, nblock_col=ncols) + CPPrecondition(ASSOCIATED(matrix_ptr),cp_failure_level,routineP,error,failure) + IF (.NOT. failure) THEN + CALL get_matrix_info(matrix_ptr, nblock_row=nrows, nblock_col=ncols) CPAssert(ncols==nrows,cp_warning_level,routineP,error,failure) - ncols=min(nrows,ncols) - allocate(myDiag(ncols),stat=stat) + ncols=MIN(nrows,ncols) + ALLOCATE(myDiag(ncols),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) myDiag=0 - call cp_init(iterator, matrix=matrix, error=error) - do - if (.not.cp_next(iterator)) exit - call cp_get(iterator,block_row=i,block_col=j,error=error) - if (i==j) then + CALL cp_init(iterator, matrix=matrix, error=error) + DO + IF (.not.cp_next(iterator)) EXIT + CALL cp_get(iterator,block_row=i,block_col=j,error=error) + IF (i==j) THEN myDiag(i)=myDiag(i)+1 - else - call cp_assert(.false.,cp_warning_level,cp_assertion_failed,& - routineP,"there is an off diagonal block! in "//& + ELSE + CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& + routineP,"there is an off diagonal BLOCK! in "//& CPSourceFileRef,error) myDiag(i)=myDiag(i)+100 myDiag(j)=myDiag(j)+100 - end if - end do - call cp_dealloc_ref(iterator,error=error) - call mp_sum(myDiag,para_env%group) + END IF + END DO + CALL cp_dealloc_ref(iterator,error=error) + CALL mp_sum(myDiag,para_env%group) ! there are off diagonal blocks - CPAssertNoFail(all(myDiag<100),cp_warning_level,routineP,error) - do i=1,size(myDiag) - myDiag(i)= mod(myDiag(i),100) - end do - CPAssert(all(myDiag==1),cp_failure_level,routineP,error,failure) - deallocate(myDiag, stat=stat) + CPAssertNoFail(ALL(myDiag<100),cp_warning_level,routineP,error) + DO i=1,SIZE(myDiag) + myDiag(i)= MOD(myDiag(i),100) + END DO + CPAssert(ALL(myDiag==1),cp_failure_level,routineP,error,failure) + DEALLOCATE(myDiag, stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if + END IF res=.not.failure !call timestop(0.0_wp,handle) -end function cp_sm_is_block_diagonal +END FUNCTION cp_sm_is_block_diagonal !*************************************************************************** !!****f* cp_matrix_utils/cp_sm_set_dist_sparsity_from_sm [1.0] * @@ -1120,62 +1136,62 @@ end function cp_sm_is_block_diagonal !! 4.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sm_set_dist_sparsity_from_sm(m_struct, para_env,& +SUBROUTINE cp_sm_set_dist_sparsity_from_sm(m_struct, para_env,& sample_matrix,error) - type(cp_b_matrix_struct_type), intent(inout) :: m_struct - type(cp_para_env_type), pointer :: para_env - type(real_matrix_type), pointer :: sample_matrix - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_b_matrix_struct_type), INTENT(inout) :: m_struct + TYPE(cp_para_env_type), POINTER :: para_env + TYPE(real_matrix_type), POINTER :: sample_matrix + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sm_set_dist_sparsity_from_sm',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sm_set_dist_sparsity_from_sm',& routineP=moduleN//':'//routineN - integer, dimension(:,:), pointer :: b_owner - integer :: nblock_cols, nblock_rows, block_row,block_col,i,j - type(cp_matrix_block_iterator) :: b_iterator - type(real_block_node_type), pointer :: block_node - failure=.false. + INTEGER, DIMENSION(:,:), POINTER :: b_owner + INTEGER :: nblock_cols, nblock_rows, block_row,block_col,i,j + TYPE(cp_matrix_block_iterator) :: b_iterator + TYPE(real_block_node_type), POINTER :: block_node + failure=.FALSE. - CPPrecondition(associated(sample_matrix),cp_failure_level,routineP,error,failure) + CPPrecondition(ASSOCIATED(sample_matrix),cp_failure_level,routineP,error,failure) CPPrecondition(m_struct%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then - call get_matrix_info(sample_matrix,nblock_row=nblock_rows, & + IF (.not.failure) THEN + CALL get_matrix_info(sample_matrix,nblock_row=nblock_rows, & nblock_col=nblock_cols) - call cp_2d_i_guarantee_size(m_struct%distribution%block_owner,& + CALL cp_2d_i_guarantee_size(m_struct%distribution%block_owner,& n_rows=nblock_rows, n_cols=nblock_cols, error=error) - call cp_2d_logical_guarantee_size(m_struct%sparsity,& + CALL cp_2d_logical_guarantee_size(m_struct%sparsity,& n_rows=nblock_rows, n_cols=nblock_cols, error=error) b_owner => m_struct%distribution%block_owner b_owner=0 - m_struct%sparsity=.true. - call cp_sm_b_i_init(b_iterator, matrix=sample_matrix, error=error) - do - if (.not.cp_sm_b_i_next(b_iterator,block_row=block_row, & - block_col=block_col,error=error)) exit + m_struct%sparsity=.TRUE. + CALL cp_sm_b_i_init(b_iterator, matrix=sample_matrix, error=error) + DO + IF (.not.cp_sm_b_i_next(b_iterator,block_row=block_row, & + block_col=block_col,error=error)) EXIT b_owner(block_row,block_col)=para_env%mepos+1 - end do - call cp_sm_b_i_dealloc_ref(b_iterator,error=error) - call mp_sum(b_owner,para_env%group) - do j=1,size(b_owner,2) - do i=1,size(b_owner,1) - if (b_owner(i,j)==0) then - b_owner(i,j)= mod(j,para_env%num_pe) - m_struct%sparsity(i,j)=.false. - else if (b_owner(i,j)==para_env%mepos+1) then + END DO + CALL cp_sm_b_i_dealloc_ref(b_iterator,error=error) + CALL mp_sum(b_owner,para_env%group) + DO j=1,SIZE(b_owner,2) + DO i=1,SIZE(b_owner,1) + IF (b_owner(i,j)==0) THEN + b_owner(i,j)= MOD(j,para_env%num_pe) + m_struct%sparsity(i,j)=.FALSE. + ELSE IF (b_owner(i,j)==para_env%mepos+1) THEN b_owner(i,j)=para_env%mepos - if (cp_debug .and. debug_this_module) then - call get_block_node(sample_matrix,block_row=i,& + IF (cp_debug .AND. debug_this_module) THEN + CALL get_block_node(sample_matrix,block_row=i,& block_col=j,block_node=block_node) - CPPostcondition(associated(block_node),cp_failure_level,routineP,error,failure) - end if - else + CPPostcondition(ASSOCIATED(block_node),cp_failure_level,routineP,error,failure) + END IF + ELSE b_owner(i,j)=b_owner(i,j)-1 CPPostcondition(b_owner(i,j) m_struct%sparsity b_owner => m_struct%distribution%block_owner - call get_matrix_info(matrix,nblock_row=nblock_rows, & + CALL get_matrix_info(matrix,nblock_row=nblock_rows, & nblock_col=nblock_cols) - if (.not.associated(sparsity)) then - call cp_assert(.false.,cp_warning_level,fromWhere=routineP,& + IF (.not.ASSOCIATED(sparsity)) THEN + CALL cp_assert(.FALSE.,cp_warning_level,fromWhere=routineP,& error_nr=cp_postcondition_failed,& message="no sparsity, allocating a full matrix "//& CPSourceFileRef,& error=error) - do i=1,nblock_rows - do j=1,nblock_cols - if (.not.associated(find_block_node(matrix,& - block_row=i,block_col=j))) then - nullify(block_val) - call add_block_node(matrix,block_row=i,& - block_col=j,block=block_val) + DO i=1,nblock_rows + DO j=1,nblock_cols + IF (.not.ASSOCIATED(find_block_node(matrix,& + block_row=i,block_col=j))) THEN + NULLIFY(block_val) + CALL add_block_node(matrix,block_row=i,& + block_col=j,BLOCK=block_val) block_val=0.0_wp - end if - end do - end do - return - end if - end if + END IF + END DO + END DO + RETURN + END IF + END IF - if (.not.failure) then - do i=1,nblock_rows - do j=1,nblock_cols - if (sparsity(i,j).and.b_owner(i,j)==para_env%mepos.and.& - .not.associated(find_block_node(matrix,& - block_row=i,block_col=j))) then - nullify(block_val) - call add_block_node(matrix,block_row=i,& - block_col=j,block=block_val) + IF (.not.failure) THEN + DO i=1,nblock_rows + DO j=1,nblock_cols + IF (sparsity(i,j).and.b_owner(i,j)==para_env%mepos.and.& + .not.ASSOCIATED(find_block_node(matrix,& + block_row=i,block_col=j))) THEN + NULLIFY(block_val) + CALL add_block_node(matrix,block_row=i,& + block_col=j,BLOCK=block_val) block_val=0.0_wp - end if - end do - end do - end if -end subroutine cp_sm_alloc_nonsparse_blocks + END IF + END DO + END DO + END IF +END SUBROUTINE cp_sm_alloc_nonsparse_blocks !*************************************************************************** !!****f* cp_matrix_utils/cp_sm_output [1.0] * @@ -1323,63 +1339,63 @@ end subroutine cp_sm_alloc_nonsparse_blocks !! 06.2002 created [fawzi] !! !!*** ********************************************************************** -subroutine cp_sm_output(logger, outputName, & +SUBROUTINE cp_sm_output(logger, outputName, & fromWhere, iter, matrix,para_env,& comment, el_format, error) - type(cp_logger_type), pointer ::logger - character(len=*) , intent(in) :: outputName - character(len=*), intent(in):: fromWhere - integer, intent(in) :: iter - type(real_matrix_type), pointer :: matrix - character(len=*), intent(in),optional :: comment, el_format - type(cp_para_env_type), pointer:: para_env - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_logger_type), POINTER ::logger + CHARACTER(len=*) , INTENT(in) :: outputName + CHARACTER(len=*), INTENT(in):: fromWhere + INTEGER, INTENT(in) :: iter + TYPE(real_matrix_type), POINTER :: matrix + CHARACTER(len=*), INTENT(in),OPTIONAL :: comment, el_format + TYPE(cp_para_env_type), POINTER:: para_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='cp_sm_output',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='cp_sm_output',& routineP=moduleN//':'//routineN - character(len=40) :: symmetry - character(len=60) :: name - real(wp), dimension(:,:), pointer :: full_matrix - failure=.false. + CHARACTER(len=40) :: symmetry + CHARACTER(len=60) :: name + REAL(wp), DIMENSION(:,:), POINTER :: full_matrix + failure=.FALSE. - CPPrecondition(associated(matrix),cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (cp_would_output(logger, outputName , fromWhere, iter)) then - call get_matrix_info(matrix=matrix,& + CPPrecondition(ASSOCIATED(matrix),cp_failure_level,routineP,error,failure) + IF (.NOT. failure) THEN + IF (cp_would_output(logger, outputName , fromWhere, iter)) THEN + CALL get_matrix_info(matrix=matrix,& matrix_name=name,& matrix_symmetry=symmetry) - nullify (full_matrix) - call copy_sparse_to_full_matrix(matrix,full_matrix) - if (symmetry == "symmetric") then - call symmetrize_matrix(full_matrix,"upper_to_lower") - else if (symmetry == "antisymmetric") then - call symmetrize_matrix(full_matrix,"anti_upper_to_lower") - else if (symmetry /= "none") then - call cp_assert(.false.,cp_warning_level,cp_assertion_failed,& + NULLIFY (full_matrix) + CALL copy_sparse_to_full_matrix(matrix,full_matrix) + IF (symmetry == "symmetric") THEN + CALL symmetrize_matrix(full_matrix,"upper_to_lower") + ELSE IF (symmetry == "antisymmetric") THEN + CALL symmetrize_matrix(full_matrix,"anti_upper_to_lower") + ELSE IF (symmetry /= "NONE") THEN + CALL cp_assert(.FALSE.,cp_warning_level,cp_assertion_failed,& fromWhere=routineP,message="Unknown matrix structure in"//& CPSourceFileRef,& error=error) - end if + END IF - call mp_sum(full_matrix,para_env%group) + CALL mp_sum(full_matrix,para_env%group) - if (present(comment)) then - call cp_2d_r_output(logger=logger, outputName=outputName, & + IF (PRESENT(comment)) THEN + CALL cp_2d_r_output(logger=logger, outputName=outputName, & fromWhere=fromWhere, iter=iter, array=full_matrix,& comment=comment, el_format=el_format, error=error) - else - call cp_2d_r_output(logger=logger, outputName=outputName, & + ELSE + CALL cp_2d_r_output(logger=logger, outputName=outputName, & fromWhere=fromWhere, iter=iter, array=full_matrix,& comment=name, el_format=el_format, error=error) - end if - if (associated(full_matrix)) then - deallocate(full_matrix) - end if - end if - end if -end subroutine cp_sm_output + END IF + IF (ASSOCIATED(full_matrix)) THEN + DEALLOCATE(full_matrix) + END IF + END IF + END IF +END SUBROUTINE cp_sm_output !*************************************************************************** -end module cp_matrix_utils +END MODULE cp_matrix_utils diff --git a/src/cp_output_handling.F b/src/cp_output_handling.F index 09815c5a6a..90d082666b 100644 --- a/src/cp_output_handling.F +++ b/src/cp_output_handling.F @@ -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 diff --git a/src/cp_para_types.F b/src/cp_para_types.F index c6cac7568c..0a38f0da4e 100755 --- a/src/cp_para_types.F +++ b/src/cp_para_types.F @@ -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 diff --git a/src/cp_sll_int_ptr_tests.F b/src/cp_sll_int_ptr_tests.F index 4a2be15cd3..438492da08 100644 --- a/src/cp_sll_int_ptr_tests.F +++ b/src/cp_sll_int_ptr_tests.F @@ -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 diff --git a/src/cp_sll_int_tests.F b/src/cp_sll_int_tests.F index 62fd22c7d1..676d1d01f0 100644 --- a/src/cp_sll_int_tests.F +++ b/src/cp_sll_int_tests.F @@ -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 diff --git a/src/cp_sp_iterators.F b/src/cp_sp_iterators.F index f020fa0360..5e96d280fe 100644 --- a/src/cp_sp_iterators.F +++ b/src/cp_sp_iterators.F @@ -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 diff --git a/src/pao_bas_projection_types.F b/src/pao_bas_projection_types.F index 0c51e25aba..7d8d54995c 100755 --- a/src/pao_bas_projection_types.F +++ b/src/pao_bas_projection_types.F @@ -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 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 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 diff --git a/src/pao_env_methods.F b/src/pao_env_methods.F index 05e72d9f85..0b5ddeba33 100644 --- a/src/pao_env_methods.F +++ b/src/pao_env_methods.F @@ -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 diff --git a/src/pao_glob_angles_methods.F b/src/pao_glob_angles_methods.F index 183616ed3f..a10aa53e43 100644 --- a/src/pao_glob_angles_methods.F +++ b/src/pao_glob_angles_methods.F @@ -26,41 +26,59 @@ !! !! SOURCE !**************************************************************************** -module pao_glob_angles_methods - 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, cp_assertion_failed, cp_error_init,& - cp_error_get_print_level, cp_error_get_stop_level, cp_error_get_level,& - cp_error_set, cp_error_dealloc_ref, & - cp_error_propagate_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 - use cp_block_matrix, only: cp_block_matrix_type, cp_block_matrix_p_type,& - cp_sp_create, cp_dealloc, cp_get_matrix, cp_retain, cp_release - use cp_para_types, only: cp_para_env_type - use cp_b_matrix_structure, only: cp_b_matrix_struct_type - use pao_bas_projection_types, only: pao_bas_projection_type - use qs_environment_types, only: qs_environment_type, get_qs_env - use cp_array_utils, only: cp_1d_logical_guarantee_size,& - cp_1d_r_guarantee_size - implicit none - private +MODULE pao_glob_angles_methods + USE cp_array_utils, ONLY: cp_1d_logical_guarantee_size,& + cp_1d_r_guarantee_size + USE cp_b_matrix_structure, ONLY: cp_b_matrix_struct_type + USE cp_block_matrix, ONLY: cp_block_matrix_p_type,& + cp_block_matrix_type,& + cp_dealloc,& + 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_print_level,& + cp_error_get_stop_level,& + cp_error_init,& + cp_error_message,& + cp_error_propagate_error,& + cp_error_set,& + cp_error_type + USE cp_log_handling, ONLY: cp_failure_level,& + 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: pao_bas_projection_type + USE pao_types, ONLY: cp_get,& + pao_env_type,& + pao_glob_angles_type + USE qs_environment_types, ONLY: get_qs_env,& + qs_environment_type + USE timings, ONLY: timeset,& + timestop + IMPLICIT NONE + PRIVATE - logical, private, parameter :: debug_this_module=.true. - character(len=*), private, parameter :: moduleN='pao_glob_angles_methods' + LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. + CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='pao_glob_angles_methods' ! core procedures - public :: cp_init, cp_dealloc_ref, cp_set, cp_get, cp_create, cp_dealloc,& + PUBLIC :: cp_init, cp_dealloc_ref, cp_set, cp_get, cp_create, cp_dealloc,& cp_did_change ! core functions - public :: cp_validate, cp_valid + PUBLIC :: cp_validate, cp_valid ! the underlying functions - public :: pao_g_ang_init, pao_g_ang_dealloc_ref, & + PUBLIC :: pao_g_ang_init, pao_g_ang_dealloc_ref, & pao_g_ang_create, pao_g_ang_dealloc,& pao_g_ang_validate, pao_g_ang_valid,& pao_g_ang_set, pao_g_ang_get, pao_g_ang_did_change @@ -72,64 +90,64 @@ module pao_glob_angles_methods !! initializes the first, argument. !! Support optional initial values that depend on the !! first argument - interface cp_init - module procedure pao_g_ang_init - end interface + INTERFACE cp_init + MODULE PROCEDURE pao_g_ang_init + END INTERFACE !! Deallocates the memory allocated by the first argument. !! Supports error=error - interface cp_dealloc_ref - module procedure pao_g_ang_dealloc_ref - end interface + INTERFACE cp_dealloc_ref + MODULE PROCEDURE pao_g_ang_dealloc_ref + END INTERFACE !! Allocates and initialize a new object returning a pointer to it in !! the first argument - interface cp_create - module procedure pao_g_ang_create - end interface + INTERFACE cp_create + MODULE PROCEDURE pao_g_ang_create + END INTERFACE !! Deallocates the memory used by the first argument, and the object !! itself - interface cp_dealloc - module procedure pao_g_ang_dealloc - end interface + INTERFACE cp_dealloc + MODULE PROCEDURE pao_g_ang_dealloc + 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_g_ang_validate - end interface + INTERFACE cp_validate + MODULE PROCEDURE pao_g_ang_validate + 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_g_ang_valid - end interface + INTERFACE cp_valid + MODULE PROCEDURE pao_g_ang_valid + 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_g_ang_set - end interface + INTERFACE cp_set + MODULE PROCEDURE pao_g_ang_set + END INTERFACE !! 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_g_ang_get - end interface + INTERFACE cp_get + MODULE PROCEDURE pao_g_ang_get + END INTERFACE !! tells the object that its internal values have changes and its cached !! values may be invalid - interface cp_did_change - module procedure pao_g_ang_did_change - end interface + INTERFACE cp_did_change + MODULE PROCEDURE pao_g_ang_did_change + END INTERFACE ! +++ end of the core methods +++ !!*** !**************************************************************************** -contains +CONTAINS ! ======= core methods ====== @@ -170,35 +188,35 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_ang_init(glob_angles, qs_env, global_env, angles, source,& + SUBROUTINE pao_g_ang_init(glob_angles, qs_env, global_env, angles, source,& min_overlap_m, min_hamiltonian_m, error) - type(pao_glob_angles_type), intent(out) :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - real(kind=wp), optional, dimension(:), intent(in) :: angles - type(pao_glob_angles_type), intent(in), optional :: source - type(cp_block_matrix_p_type), intent(in), optional, & - dimension(:) :: min_overlap_m, min_hamiltonian_m - type(cp_error_type), optional, intent(inout) :: error + TYPE(pao_glob_angles_type), INTENT(out) :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + REAL(kind=wp), OPTIONAL, DIMENSION(:), INTENT(in) :: angles + TYPE(pao_glob_angles_type), INTENT(in), OPTIONAL :: source + TYPE(cp_block_matrix_p_type), INTENT(in), OPTIONAL, & + DIMENSION(:) :: min_overlap_m, min_hamiltonian_m + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_ang_init' - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_ang_init' + failure=.FALSE. - nullify(glob_angles%angles, glob_angles%unitary_t,& + NULLIFY(glob_angles%angles, glob_angles%unitary_t,& glob_angles%ut_calculated, glob_angles%min_overlap_m, & glob_angles%min_hamiltonian_m, glob_angles%NUi_injection_calculated,& glob_angles%NUi_injection) - glob_angles%m_s_m_valid=.false. - glob_angles%m_h_m_valid=.false. - glob_angles%initialized = .true. - if (.not.failure) then - call pao_g_ang_set(glob_angles,qs_env=qs_env, global_env=global_env,& + glob_angles%m_s_m_valid=.FALSE. + glob_angles%m_h_m_valid=.FALSE. + glob_angles%initialized = .TRUE. + IF (.not.failure) THEN + CALL pao_g_ang_set(glob_angles,qs_env=qs_env, global_env=global_env,& angles=angles,& source=source, min_hamiltonian_m=min_hamiltonian_m,& min_overlap_m=min_overlap_m, error=error) - end if - end subroutine pao_g_ang_init + END IF + END SUBROUTINE pao_g_ang_init !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_ang_dealloc_ref [1.0] * @@ -233,36 +251,36 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_ang_dealloc_ref(glob_angles,global_env, error) - type(pao_glob_angles_type), intent(inout) :: glob_angles - type(global_environment_type), intent(in), target :: global_env - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE pao_g_ang_dealloc_ref(glob_angles,global_env, error) + TYPE(pao_glob_angles_type), INTENT(inout) :: glob_angles + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_ang_dealloc_ref' - integer ::stat - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_ang_dealloc_ref' + INTEGER ::stat + failure=.FALSE. CPPrecondition(glob_angles%initialized, cp_failure_level,routineP,error,failure) - failureIf: if (.not. failure) then - if (associated(glob_angles%angles)) then - deallocate(glob_angles%angles, stat=stat) + failureIf: IF (.NOT. failure) THEN + IF (ASSOCIATED(glob_angles%angles)) THEN + DEALLOCATE(glob_angles%angles, stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - if (associated(glob_angles%ut_calculated)) then - deallocate(glob_angles%ut_calculated,stat=stat) + END IF + IF (ASSOCIATED(glob_angles%ut_calculated)) THEN + DEALLOCATE(glob_angles%ut_calculated,stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - if (associated(glob_angles%NUi_injection_calculated)) then - deallocate(glob_angles%NUi_injection_calculated) + END IF + IF (ASSOCIATED(glob_angles%NUi_injection_calculated)) THEN + DEALLOCATE(glob_angles%NUi_injection_calculated) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - call cp_release(glob_angles%NUi_injection,error=error) - call cp_release(glob_angles%unitary_t,error=error) - call cp_dealloc(glob_angles%min_hamiltonian_m,error=error) - call cp_dealloc(glob_angles%min_overlap_m,error=error) - end if failureIf - end subroutine pao_g_ang_dealloc_ref + END IF + CALL cp_release(glob_angles%NUi_injection,error=error) + CALL cp_release(glob_angles%unitary_t,error=error) + CALL cp_dealloc(glob_angles%min_hamiltonian_m,error=error) + CALL cp_dealloc(glob_angles%min_overlap_m,error=error) + END IF failureIf + END SUBROUTINE pao_g_ang_dealloc_ref !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_ang_dealloc [1.0] * @@ -296,26 +314,26 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_ang_dealloc(glob_angles,global_env,error) - type(pao_glob_angles_type), pointer :: glob_angles - type(global_environment_type), intent(in), target :: global_env - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE pao_g_ang_dealloc(glob_angles,global_env,error) + TYPE(pao_glob_angles_type), POINTER :: glob_angles + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_ang_dealloc' - integer :: stat - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_ang_dealloc' + INTEGER :: stat + failure=.FALSE. - if (associated(glob_angles)) then + IF (ASSOCIATED(glob_angles)) THEN CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - call pao_g_ang_dealloc_ref(glob_angles, global_env=global_env,& + IF (.NOT. failure) THEN + CALL pao_g_ang_dealloc_ref(glob_angles, global_env=global_env,& error=error) - end if - deallocate(glob_angles,stat=stat) + END IF + DEALLOCATE(glob_angles,stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - end subroutine pao_g_ang_dealloc + END IF + END SUBROUTINE pao_g_ang_dealloc !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_ang_create [1.0] * @@ -357,32 +375,32 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_ang_create(glob_angles, qs_env, global_env, angles, source,& + SUBROUTINE pao_g_ang_create(glob_angles, qs_env, global_env, angles, source,& min_overlap_m, min_hamiltonian_m, error) - type(pao_glob_angles_type), pointer :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - real(kind=wp), optional, dimension(:), intent(in) :: angles - type(pao_glob_angles_type), intent(in), optional :: source + TYPE(pao_glob_angles_type), POINTER :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + REAL(kind=wp), OPTIONAL, DIMENSION(:), INTENT(in) :: angles + TYPE(pao_glob_angles_type), INTENT(in), OPTIONAL :: source - type(cp_block_matrix_p_type), intent(in), dimension(:), optional ::& + TYPE(cp_block_matrix_p_type), INTENT(in), DIMENSION(:), OPTIONAL ::& min_hamiltonian_m, min_overlap_m - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_ang_create' - integer :: stat - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_ang_create' + INTEGER :: stat + failure=.FALSE. - allocate(glob_angles, stat=stat) + ALLOCATE(glob_angles, stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (.not. failure) then - call pao_g_ang_init(glob_angles, qs_env=qs_env, global_env=global_env,& + IF (.NOT. failure) THEN + CALL pao_g_ang_init(glob_angles, qs_env=qs_env, global_env=global_env,& angles=angles, source=source,& min_overlap_m=min_overlap_m, min_hamiltonian_m=min_hamiltonian_m,& error=error) - end if - end subroutine pao_g_ang_create + END IF + END SUBROUTINE pao_g_ang_create !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_ang_validate [1.0] * @@ -420,31 +438,31 @@ contains !! none !! !!*** ********************************************************************** - function pao_g_ang_validate(glob_angles,qs_env,global_env, error) result(res) - logical ::res - type(pao_glob_angles_type), intent(in) :: glob_angles - type(qs_environment_type), intent(in),target :: qs_env - type(global_environment_type), intent(in), target :: global_env - type(cp_error_type), optional, intent(inout) :: error + FUNCTION pao_g_ang_validate(glob_angles,qs_env,global_env, error) RESULT(res) + LOGICAL ::res + TYPE(pao_glob_angles_type), INTENT(in) :: glob_angles + TYPE(qs_environment_type), INTENT(in),TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_ang_validate' - type(pao_env_type), pointer :: pao_env - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_ang_validate' + TYPE(pao_env_type), POINTER :: pao_env + failure=.FALSE. CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - failureIf: if (.not. failure) then - CPAssert(associated(glob_angles%angles),cp_warning_level,routineP,error,failure) - call get_qs_env(qs_env,pao_env=pao_env) - CPAssert(associated(pao_env),cp_warning_level,routineP,error,failure) - if (.not.failure) then - call cp_assert(pao_env%angles_begin_at & - (size(pao_env%angles_begin_at))-1== & - size(glob_angles%angles),cp_warning_level,& + failureIf: IF (.NOT. failure) THEN + CPAssert(ASSOCIATED(glob_angles%angles),cp_warning_level,routineP,error,failure) + CALL get_qs_env(qs_env,pao_env=pao_env) + CPAssert(ASSOCIATED(pao_env),cp_warning_level,routineP,error,failure) + IF (.not.failure) THEN + CALL cp_assert(pao_env%angles_begin_at & + (SIZE(pao_env%angles_begin_at))-1== & + SIZE(glob_angles%angles),cp_warning_level,& cp_assertion_failed, routineP,& "number of angles different from last begin_at in "//& CPSourceFileRef,& error,failure) - end if + END IF !!FM if (associated(glob_angles%ut_calculated)) then !!FM call cp_assert(size(glob_angles%ut_calculated)==& !!FM glob_angles%pao_env%n_atoms, cp_warning_level,& @@ -462,29 +480,29 @@ contains !!FM error,failure) !!FM CPAssert(associated(glob_angles%ut_calculated),cp_warning_level,routineP,error,failure) !!FM end if - if (associated(glob_angles%min_hamiltonian_m)) then + IF (ASSOCIATED(glob_angles%min_hamiltonian_m)) THEN !!FM call cp_assert(cp_validate(glob_angles%min_hamiltonian_m,& !!FM error=error), cp_warning_level,& !!FM cp_assertion_failed, routineP,& !!FM "cached invalid min_hamiltonian_m in "//& !!FM CPSourceFileRef,& !!FM error,failure) - else + ELSE CPAssert(.not.glob_angles%m_h_m_valid,cp_warning_level,routineP,error,failure) - end if - if (associated(glob_angles%min_overlap_m)) then + END IF + IF (ASSOCIATED(glob_angles%min_overlap_m)) THEN !!FM call cp_assert(cp_validate(glob_angles%min_overlap_m,& !!FM error=error), cp_warning_level,& !!FM cp_assertion_failed, routineP,& !!FM "cached invalid min_overlap_m in "//& !!FM CPSourceFileRef,& !!FM error,failure) - else + ELSE CPAssert(.not.glob_angles%m_s_m_valid,cp_warning_level,routineP,error,failure) - end if - end if failureIf + END IF + END IF failureIf res=.not.failure - end function pao_g_ang_validate + END FUNCTION pao_g_ang_validate !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_ang_set [1.0] * @@ -539,111 +557,111 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_ang_set(glob_angles, qs_env, global_env, angles,source,& + SUBROUTINE pao_g_ang_set(glob_angles, qs_env, global_env, angles,source,& min_overlap_m, min_hamiltonian_m,& m_s_m_valid, m_h_m_valid, angles_val, error) - type(pao_glob_angles_type), intent(inout) :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - real(kind=wp), optional, dimension(:), intent(in) :: angles - type(pao_glob_angles_type), optional, intent(in) :: source - type(cp_block_matrix_p_type), optional, intent(in), dimension(:) :: & + TYPE(pao_glob_angles_type), INTENT(inout) :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + REAL(kind=wp), OPTIONAL, DIMENSION(:), INTENT(in) :: angles + TYPE(pao_glob_angles_type), OPTIONAL, INTENT(in) :: source + TYPE(cp_block_matrix_p_type), OPTIONAL, INTENT(in), DIMENSION(:) :: & min_overlap_m - type(cp_block_matrix_p_type), dimension(:), intent(in),& - optional :: min_hamiltonian_m - logical, intent(in), optional :: m_h_m_valid, m_s_m_valid - real(kind=wp), intent(in), optional :: angles_val - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_block_matrix_p_type), DIMENSION(:), INTENT(in),& + OPTIONAL :: min_hamiltonian_m + LOGICAL, INTENT(in), OPTIONAL :: m_h_m_valid, m_s_m_valid + REAL(kind=wp), INTENT(in), OPTIONAL :: angles_val + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_ang_set' - type(pao_env_type), pointer :: pao_env - integer :: stat - type(cp_error_type) :: iError - call cp_error_init(iError,template_error=error) - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_ang_set' + TYPE(pao_env_type), POINTER :: pao_env + INTEGER :: stat + TYPE(cp_error_type) :: iError + CALL cp_error_init(iError,template_error=error) + failure=.FALSE. - call get_qs_env(qs_env, pao_env=pao_env) + CALL get_qs_env(qs_env, pao_env=pao_env) CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - CPPrecondition(associated(pao_env),cp_failure_level,routineP,error,failure) - failureIf: if (.not. failure) then - if (present(source)) then + CPPrecondition(ASSOCIATED(pao_env),cp_failure_level,routineP,error,failure) + failureIf: IF (.NOT. failure) THEN + IF (PRESENT(source)) THEN CPPrecondition(source%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_error_set(iError, print_level=max(cp_failure_level,& + IF (.not.failure) THEN + CALL cp_error_set(iError, print_level=MAX(cp_failure_level,& cp_error_get_print_level(iError)),& - stop_level=max(cp_failure_level,& + stop_level=MAX(cp_failure_level,& cp_error_get_stop_level(iError))) - if (associated(source%angles)) then - call cp_1d_r_guarantee_size(glob_angles%angles,& - size(source%angles),init=0.0_wp,& + IF (ASSOCIATED(source%angles)) THEN + CALL cp_1d_r_guarantee_size(glob_angles%angles,& + SIZE(source%angles),init=0.0_wp,& error=iError) - call cp_assert(cp_error_get_level(iError) glob_angles%angles - if (present(m_s_m_valid)) m_s_m_valid = glob_angles%m_s_m_valid - if (present(m_h_m_valid)) m_h_m_valid=glob_angles%m_h_m_valid - if (present(unitary_t)) then - call get_qs_env(qs_env, pao_env=pao_env) - call cp_get(pao_env, full_bas_diag_m_struct=m_struct) - if (.not.associated(glob_angles%unitary_t)) then - call cp_sp_create(glob_angles%unitary_t,& + n_atoms=SIZE(qs_env%particle_set) + failureIf: IF (.NOT. failure) THEN + IF (PRESENT(angles)) angles => glob_angles%angles + IF (PRESENT(m_s_m_valid)) m_s_m_valid = glob_angles%m_s_m_valid + IF (PRESENT(m_h_m_valid)) m_h_m_valid=glob_angles%m_h_m_valid + IF (PRESENT(unitary_t)) THEN + CALL get_qs_env(qs_env, pao_env=pao_env) + CALL cp_get(pao_env, full_bas_diag_m_struct=m_struct) + IF (.not.ASSOCIATED(glob_angles%unitary_t)) THEN + CALL cp_sp_create(glob_angles%unitary_t,& matrix_struct=m_struct,& error=error) - end if - if (.not.associated(glob_angles%ut_calculated)) then - allocate(glob_angles%ut_calculated(n_atoms),& + END IF + IF (.not.ASSOCIATED(glob_angles%ut_calculated)) THEN + ALLOCATE(glob_angles%ut_calculated(n_atoms),& stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (stat==0) glob_angles%ut_calculated=.false. - end if + IF (stat==0) glob_angles%ut_calculated=.FALSE. + END IF unitary_t => glob_angles%unitary_t - end if - if (present(ut_calculated).and.& - .not.associated(glob_angles%ut_calculated)) then - allocate(glob_angles%ut_calculated(n_atoms),& + END IF + IF (PRESENT(ut_calculated).AND.& + .not.ASSOCIATED(glob_angles%ut_calculated)) THEN + ALLOCATE(glob_angles%ut_calculated(n_atoms),& stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (stat==0) glob_angles%ut_calculated=.false. + IF (stat==0) glob_angles%ut_calculated=.FALSE. ut_calculated => glob_angles%ut_calculated - end if - if (present(NUi_injection)) then - call get_qs_env(qs_env, pao_env=pao_env) - call cp_get(pao_env, full_min_bas_m_struct=m_struct) - if (.not.associated(glob_angles%NUi_injection)) then - call cp_sp_create(glob_angles%NUi_injection,& + END IF + IF (PRESENT(NUi_injection)) THEN + CALL get_qs_env(qs_env, pao_env=pao_env) + CALL cp_get(pao_env, full_min_bas_m_struct=m_struct) + IF (.not.ASSOCIATED(glob_angles%NUi_injection)) THEN + CALL cp_sp_create(glob_angles%NUi_injection,& matrix_struct=m_struct,& error=error) - end if - if (.not.associated(glob_angles%NUi_injection_calculated)) then - allocate(glob_angles%NUi_injection_calculated(n_atoms),& + END IF + IF (.not.ASSOCIATED(glob_angles%NUi_injection_calculated)) THEN + ALLOCATE(glob_angles%NUi_injection_calculated(n_atoms),& stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (stat==0) glob_angles%NUi_injection_calculated=.false. - end if + IF (stat==0) glob_angles%NUi_injection_calculated=.FALSE. + END IF NUi_injection => glob_angles%NUi_injection - end if - if (present(NUi_injection_calculated).and.& - .not.associated(glob_angles%NUi_injection_calculated)) then - allocate(glob_angles%NUi_injection_calculated(n_atoms),& + END IF + IF (PRESENT(NUi_injection_calculated).AND.& + .not.ASSOCIATED(glob_angles%NUi_injection_calculated)) THEN + ALLOCATE(glob_angles%NUi_injection_calculated(n_atoms),& stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - if (stat==0) glob_angles%NUi_injection_calculated=.false. + IF (stat==0) glob_angles%NUi_injection_calculated=.FALSE. NUi_injection_calculated => glob_angles%NUi_injection_calculated - end if - end if failureIf - end subroutine pao_g_ang_get + END IF + END IF failureIf + END SUBROUTINE pao_g_ang_get !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_ang_valid [1.0] * @@ -814,44 +832,44 @@ contains !! none !! !!*** ********************************************************************** - function pao_g_ang_valid(glob_angles, qs_env, global_env, error) result(res) - logical ::res - type(pao_glob_angles_type), intent(in) :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - type(cp_error_type), optional, intent(inout) :: error + FUNCTION pao_g_ang_valid(glob_angles, qs_env, global_env, error) RESULT(res) + LOGICAL ::res + TYPE(pao_glob_angles_type), INTENT(in) :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_ang_valid' - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_ang_valid' + failure=.FALSE. CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (.not.(associated(glob_angles%angles).and.& - (.not.associated(glob_angles%unitary_t).or.& - associated(glob_angles%ut_calculated)) .and.& - (.not.glob_angles%m_s_m_valid .or.& - associated(glob_angles%min_overlap_m)).and.& - (.not.glob_angles%m_h_m_valid .or.& - associated(glob_angles%min_hamiltonian_m))& - )) then - CPAssert(associated(glob_angles%angles),cp_warning_level,routineP,error,failure) - if (associated(glob_angles%unitary_t)) then - CPAssert(associated(glob_angles%ut_calculated),cp_warning_level,routineP,error,failure) - end if - if (associated(glob_angles%NUi_injection_calculated)) then - CPAssert(associated(glob_angles%NUi_injection),cp_warning_level,routineP,error,failure) - end if - if (glob_angles%m_s_m_valid) then - CPAssert(associated(glob_angles%min_overlap_m),cp_warning_level,routineP,error,failure) - end if - if (glob_angles%m_h_m_valid) then - CPAssert(associated(glob_angles%min_hamiltonian_m),cp_warning_level,routineP,error,failure) - end if - end if - end if + IF (.NOT. failure) THEN + IF (.NOT.(ASSOCIATED(glob_angles%angles).AND.& + (.not.ASSOCIATED(glob_angles%unitary_t).OR.& + ASSOCIATED(glob_angles%ut_calculated)) .AND.& + (.not.glob_angles%m_s_m_valid .OR.& + ASSOCIATED(glob_angles%min_overlap_m)).AND.& + (.not.glob_angles%m_h_m_valid .OR.& + ASSOCIATED(glob_angles%min_hamiltonian_m))& + )) THEN + CPAssert(ASSOCIATED(glob_angles%angles),cp_warning_level,routineP,error,failure) + IF (ASSOCIATED(glob_angles%unitary_t)) THEN + CPAssert(ASSOCIATED(glob_angles%ut_calculated),cp_warning_level,routineP,error,failure) + END IF + IF (ASSOCIATED(glob_angles%NUi_injection_calculated)) THEN + CPAssert(ASSOCIATED(glob_angles%NUi_injection),cp_warning_level,routineP,error,failure) + END IF + IF (glob_angles%m_s_m_valid) THEN + CPAssert(ASSOCIATED(glob_angles%min_overlap_m),cp_warning_level,routineP,error,failure) + END IF + IF (glob_angles%m_h_m_valid) THEN + CPAssert(ASSOCIATED(glob_angles%min_hamiltonian_m),cp_warning_level,routineP,error,failure) + END IF + END IF + END IF res=.not.failure - end function pao_g_ang_valid + END FUNCTION pao_g_ang_valid !*************************************************************************** ! ===== special methods ==== @@ -882,47 +900,47 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_angles_set_unitary_t(glob_angles,& + SUBROUTINE pao_g_angles_set_unitary_t(glob_angles,& new_value, ut_calculated,error) - type(pao_glob_angles_type), intent(inout) :: glob_angles - type(cp_block_matrix_type), target, optional, intent(in) :: new_value - logical, dimension(:), intent(in), optional, target :: ut_calculated - type(cp_error_type), optional, intent(inout) :: error + TYPE(pao_glob_angles_type), INTENT(inout) :: glob_angles + TYPE(cp_block_matrix_type), TARGET, OPTIONAL, INTENT(in) :: new_value + LOGICAL, DIMENSION(:), INTENT(in), OPTIONAL, TARGET :: ut_calculated + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_angles_set_unitary_t' - logical, dimension(:),pointer :: ut_c - type(cp_block_matrix_type), pointer :: n_value - type (cp_error_type) :: iError - call cp_error_init(iError, template_error=error, & - print_level=max(cp_failure_level, cp_error_get_print_level(error))) - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_angles_set_unitary_t' + LOGICAL, DIMENSION(:),POINTER :: ut_c + TYPE(cp_block_matrix_type), POINTER :: n_value + TYPE (cp_error_type) :: iError + CALL cp_error_init(iError, template_error=error, & + print_level=MAX(cp_failure_level, cp_error_get_print_level(error))) + failure=.FALSE. - if (present(ut_calculated)) then + IF (PRESENT(ut_calculated)) THEN ut_c => ut_calculated - if (associated(ut_c)) then - call cp_1d_logical_guarantee_size(glob_angles%ut_calculated,& - size(ut_calculated),error=iError) - call cp_error_propagate_error(iError,routineP,& + IF (ASSOCIATED(ut_c)) THEN + CALL cp_1d_logical_guarantee_size(glob_angles%ut_calculated,& + SIZE(ut_calculated),error=iError) + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure,cp_failure_level) glob_angles%ut_calculated=ut_calculated - else if (associated(glob_angles%ut_calculated)) then - deallocate(glob_angles%ut_calculated) - end if - end if - if (present(new_value)) then + ELSE IF (ASSOCIATED(glob_angles%ut_calculated)) THEN + DEALLOCATE(glob_angles%ut_calculated) + END IF + END IF + IF (PRESENT(new_value)) THEN n_value => new_value - if (associated(n_value)) then - call cp_retain(n_value,error=error) - call cp_release(glob_angles%unitary_t, error=error) + IF (ASSOCIATED(n_value)) THEN + CALL cp_retain(n_value,error=error) + CALL cp_release(glob_angles%unitary_t, error=error) glob_angles%unitary_t => new_value - else if (associated(glob_angles%unitary_t)) then + ELSE IF (ASSOCIATED(glob_angles%unitary_t)) THEN ! do not dealloc ?? - call cp_release(glob_angles%unitary_t,error=error) - end if - end if - end subroutine pao_g_angles_set_unitary_t + CALL cp_release(glob_angles%unitary_t,error=error) + END IF + END IF + END SUBROUTINE pao_g_angles_set_unitary_t !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_angles_set_min_s_m [1.0] * @@ -950,36 +968,36 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_angles_set_min_s_m(glob_angles, new_value,error) - type(pao_glob_angles_type), intent(inout) :: glob_angles - type(cp_block_matrix_p_type), dimension(:),optional, & - intent(in) :: new_value - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE pao_g_angles_set_min_s_m(glob_angles, new_value,error) + TYPE(pao_glob_angles_type), INTENT(inout) :: glob_angles + TYPE(cp_block_matrix_p_type), DIMENSION(:),OPTIONAL, & + INTENT(in) :: new_value + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_glob_angles_methods:pao_g_angles_set_min_s_m' - integer :: i, stat - type(cp_block_matrix_type), pointer :: n_val - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_glob_angles_methods:pao_g_angles_set_min_s_m' + INTEGER :: i, stat + TYPE(cp_block_matrix_type), POINTER :: n_val + failure=.FALSE. - if (present(new_value)) then - glob_angles%m_s_m_valid=.true. - do i=1,size(new_value) + IF (PRESENT(new_value)) THEN + glob_angles%m_s_m_valid=.TRUE. + DO i=1,SIZE(new_value) n_val => new_value(i)%matrix - call cp_retain(n_val, error=error) - end do - if (associated(glob_angles%min_overlap_m)) then - call cp_dealloc(glob_angles%min_overlap_m,error=error) - end if - allocate(glob_angles%min_overlap_m(size(new_value)),stat=stat) - do i=1,size(new_value) + CALL cp_retain(n_val, error=error) + END DO + IF (ASSOCIATED(glob_angles%min_overlap_m)) THEN + CALL cp_dealloc(glob_angles%min_overlap_m,error=error) + END IF + ALLOCATE(glob_angles%min_overlap_m(SIZE(new_value)),stat=stat) + DO i=1,SIZE(new_value) glob_angles%min_overlap_m(i)%matrix => new_value(i)%matrix - end do - else if (associated(glob_angles%min_overlap_m)) then + END DO + ELSE IF (ASSOCIATED(glob_angles%min_overlap_m)) THEN ! do not dealloc ?? - call cp_dealloc(glob_angles%min_overlap_m,error=error) - end if - end subroutine pao_g_angles_set_min_s_m + CALL cp_dealloc(glob_angles%min_overlap_m,error=error) + END IF + END SUBROUTINE pao_g_angles_set_min_s_m !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_angles_set_min_h_m [1.0] * @@ -1007,37 +1025,37 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_angles_set_min_h_m(glob_angles, new_value,error) - type(pao_glob_angles_type), intent(inout) :: glob_angles - type(cp_block_matrix_p_type), dimension(:), optional, & - intent(in) :: new_value - type(cp_error_type), optional, intent(inout) :: error + SUBROUTINE pao_g_angles_set_min_h_m(glob_angles, new_value,error) + TYPE(pao_glob_angles_type), INTENT(inout) :: glob_angles + TYPE(cp_block_matrix_p_type), DIMENSION(:), OPTIONAL, & + INTENT(in) :: new_value + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='pao_g_angles_set_min_h_m',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='pao_g_angles_set_min_h_m',& routineP=moduleN//':'//routineN - integer :: i, stat - type(cp_block_matrix_type), pointer :: n_val - failure=.false. + INTEGER :: i, stat + TYPE(cp_block_matrix_type), POINTER :: n_val + failure=.FALSE. - if (present(new_value)) then - glob_angles%m_s_m_valid=.true. - do i=1,size(new_value) + IF (PRESENT(new_value)) THEN + glob_angles%m_s_m_valid=.TRUE. + DO i=1,SIZE(new_value) n_val => new_value(i)%matrix - call cp_retain(n_val, error=error) - end do - if (associated(glob_angles%min_overlap_m)) then - call cp_dealloc(glob_angles%min_overlap_m,error=error) - end if - allocate(glob_angles%min_overlap_m(size(new_value)),stat=stat) - do i=1,size(new_value) + CALL cp_retain(n_val, error=error) + END DO + IF (ASSOCIATED(glob_angles%min_overlap_m)) THEN + CALL cp_dealloc(glob_angles%min_overlap_m,error=error) + END IF + ALLOCATE(glob_angles%min_overlap_m(SIZE(new_value)),stat=stat) + DO i=1,SIZE(new_value) glob_angles%min_overlap_m(i)%matrix => new_value(i)%matrix - end do - else if (associated(glob_angles%min_overlap_m)) then + END DO + ELSE IF (ASSOCIATED(glob_angles%min_overlap_m)) THEN ! do not dealloc ?? - call cp_dealloc(glob_angles%min_overlap_m,error=error) - end if - end subroutine pao_g_angles_set_min_h_m + CALL cp_dealloc(glob_angles%min_overlap_m,error=error) + END IF + END SUBROUTINE pao_g_angles_set_min_h_m !*************************************************************************** !!****f* pao_glob_angles_methods/pao_g_ang_did_change [1.0] * @@ -1079,66 +1097,66 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_ang_did_change(glob_angles,qs_env,global_env,& + SUBROUTINE pao_g_ang_did_change(glob_angles,qs_env,global_env,& h_changed, s_changed,& angles_changed, full_reset, error) - type(pao_glob_angles_type), intent(inout),target :: glob_angles - type(qs_environment_type), intent(in),target :: qs_env - type(global_environment_type), intent(in),target ::global_env - logical, intent(in), optional :: h_changed, s_changed, & + TYPE(pao_glob_angles_type), INTENT(inout),TARGET :: glob_angles + TYPE(qs_environment_type), INTENT(in),TARGET :: qs_env + TYPE(global_environment_type), INTENT(in),TARGET ::global_env + LOGICAL, INTENT(in), OPTIONAL :: h_changed, s_changed, & angles_changed, full_reset - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: handle, stat - character(len=*), parameter :: routineN='pao_g_ang_did_change',& + LOGICAL :: failure + INTEGER :: handle, stat + CHARACTER(len=*), PARAMETER :: routineN='pao_g_ang_did_change',& routineP=moduleN//':'//routineN - logical :: h_c,s_c, a_c, full_r + LOGICAL :: h_c,s_c, a_c, full_r !call timeset(routineN,'I',moduleN,handle) - failure=.false. - h_c=.true. ; s_c=.false. ; a_c=.true. ; full_r=.false. + failure=.FALSE. + h_c=.TRUE. ; s_c=.FALSE. ; a_c=.TRUE. ; full_r=.FALSE. CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - if (present(h_changed)) h_c=h_changed - if (present(s_changed)) s_c=s_changed - if (present(angles_changed)) a_c=angles_changed - if (present(full_reset)) full_r=full_reset + IF (.NOT. failure) THEN + IF (PRESENT(h_changed)) h_c=h_changed + IF (PRESENT(s_changed)) s_c=s_changed + IF (PRESENT(angles_changed)) a_c=angles_changed + IF (PRESENT(full_reset)) full_r=full_reset glob_angles%m_h_m_valid=glob_angles%m_h_m_valid.and.& - .not.(h_c.or.s_c.or.a_c.or.full_r) + .NOT.(h_c.or.s_c.or.a_c.or.full_r) glob_angles%m_s_m_valid=glob_angles%m_s_m_valid.and.& - .not.(s_c.or.a_c.or.full_r) - if (associated(glob_angles%ut_calculated).and.a_c) then - glob_angles%ut_calculated=.false. - end if - if (associated(glob_angles%NUi_injection_calculated).and.a_c) then - glob_angles%NUi_injection_calculated=.false. - end if - if (full_r.or.s_c) then - call cp_release(glob_angles%unitary_t,error=error) - call cp_release(glob_angles%NUi_injection,error=error) - call cp_dealloc(glob_angles%min_hamiltonian_m,error=error) - call cp_dealloc(glob_angles%min_overlap_m) - if (associated(glob_angles%ut_calculated)) then - if (full_r) then - deallocate(glob_angles%ut_calculated, stat=stat) + .NOT.(s_c.or.a_c.or.full_r) + IF (ASSOCIATED(glob_angles%ut_calculated).and.a_c) THEN + glob_angles%ut_calculated=.FALSE. + END IF + IF (ASSOCIATED(glob_angles%NUi_injection_calculated).and.a_c) THEN + glob_angles%NUi_injection_calculated=.FALSE. + END IF + IF (full_r.or.s_c) THEN + CALL cp_release(glob_angles%unitary_t,error=error) + CALL cp_release(glob_angles%NUi_injection,error=error) + CALL cp_dealloc(glob_angles%min_hamiltonian_m,error=error) + CALL cp_dealloc(glob_angles%min_overlap_m) + IF (ASSOCIATED(glob_angles%ut_calculated)) THEN + IF (full_r) THEN + DEALLOCATE(glob_angles%ut_calculated, stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - else - glob_angles%ut_calculated=.false. - end if - end if - if (associated(glob_angles%NUi_injection_calculated)) then - if (full_r) then - deallocate(glob_angles%NUi_injection_calculated,stat=stat) + ELSE + glob_angles%ut_calculated=.FALSE. + END IF + END IF + IF (ASSOCIATED(glob_angles%NUi_injection_calculated)) THEN + IF (full_r) THEN + DEALLOCATE(glob_angles%NUi_injection_calculated,stat=stat) CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - else - glob_angles%NUi_injection_calculated=.false. - end if - end if - end if - end if + ELSE + glob_angles%NUi_injection_calculated=.FALSE. + END IF + END IF + END IF + END IF !call timestop(0.0_wp,handle) - end subroutine pao_g_ang_did_change + END SUBROUTINE pao_g_ang_did_change !*************************************************************************** -end module pao_glob_angles_methods +END MODULE pao_glob_angles_methods diff --git a/src/pao_plain_rot.F b/src/pao_plain_rot.F index c403b7577c..ba02c423f8 100644 --- a/src/pao_plain_rot.F +++ b/src/pao_plain_rot.F @@ -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 diff --git a/src/pao_plain_rot_tests.F b/src/pao_plain_rot_tests.F index f879c62efe..21988909ef 100644 --- a/src/pao_plain_rot_tests.F +++ b/src/pao_plain_rot_tests.F @@ -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 diff --git a/src/pao_proj_methods.F b/src/pao_proj_methods.F index b0818c37f5..67fbf49a1a 100644 --- a/src/pao_proj_methods.F +++ b/src/pao_proj_methods.F @@ -27,65 +27,86 @@ !! !! SOURCE !***************************************************************************** -module pao_proj_methods - 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, cp_debug, cp_precondition_failed, cp_error_init,& - cp_error_dealloc_ref, cp_error_propagate_error - use kinds, only: wp=>dp - use global_types, only: global_environment_type - use timings, only: timeset, timestop - use pao_types, only: pao_env_type, pao_glob_angles_type, pao_env_get - use cp_matrix_utils, only: cp_matrix_block_iterator, cp_next, cp_init,& - cp_dealloc_ref, cp_get - use cp_block_matrix, only: cp_block_matrix_p_type, cp_block_matrix_type,& - cp_sp_create - use pao_l_angles_methods, only: pao_local_angles_type, cp_get, cp_init, & - cp_dealloc_ref, cp_set - use pao_qs_env_methods, only: pao_qs_env_get - use sparse_matrix_types, only: real_matrix_type, real_matrix_p_type,& - get_block_node, add_block_node - use qs_environment_types, only: qs_environment_type, get_qs_env - use message_passing, only: mp_sum - use cp_b_matrix_structure, only: cp_b_matrix_struct_type - use cp_para_types, only: cp_para_env_type - implicit none - private +MODULE pao_proj_methods + USE cp_b_matrix_structure, ONLY: cp_b_matrix_struct_type + 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_assertion_failed,& + cp_debug,& + cp_error_dealloc_ref,& + cp_error_init,& + cp_error_message,& + cp_error_propagate_error,& + cp_error_type,& + cp_precondition_failed + USE cp_log_handling, ONLY: cp_failure_level,& + cp_to_string,& + cp_warning_level + USE cp_matrix_utils, ONLY: cp_dealloc_ref,& + cp_get,& + cp_init,& + cp_matrix_block_iterator,& + cp_next + USE cp_para_types, ONLY: cp_para_env_type + USE global_types, ONLY: global_environment_type + USE kinds, ONLY: wp=>dp + USE message_passing, ONLY: mp_sum + USE pao_l_angles_methods, ONLY: cp_dealloc_ref,& + cp_get,& + cp_init,& + cp_set,& + pao_local_angles_type + USE pao_qs_env_methods, ONLY: pao_qs_env_get + USE pao_types, ONLY: pao_env_get,& + pao_env_type,& + pao_glob_angles_type + USE qs_environment_types, ONLY: get_qs_env,& + qs_environment_type + USE sparse_matrix_types, ONLY: add_block_node,& + get_block_node,& + real_matrix_p_type,& + real_matrix_type + USE timings, ONLY: timeset,& + timestop + IMPLICIT NONE + PRIVATE - logical, private, parameter :: debug_this_module=.false. - character(len=*), private, parameter :: moduleN='pao_proj_methods' + LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.FALSE. + CHARACTER(len=*), PRIVATE, PARAMETER :: moduleN='pao_proj_methods' - public :: cp_get + PUBLIC :: cp_get ! projection - injection - public :: cp_m2f, cp_f2m, cp_m2f_with_B_M_pi + PUBLIC :: cp_m2f, cp_f2m, cp_m2f_with_B_M_pi - public :: pao_g_ang_get_min_m, sm_matrix_transf_to_m,& + PUBLIC :: pao_g_ang_get_min_m, sm_matrix_transf_to_m,& sm_matrix_transf_to_f, pao_m_m2f_with_b_m_pi,& sm_matrix_transf_p_to_m - interface cp_get - module procedure pao_g_ang_get_min_m - end interface + INTERFACE cp_get + MODULE PROCEDURE pao_g_ang_get_min_m + END INTERFACE ! transfer from full basis to min basis - interface cp_f2m - module procedure sm_matrix_transf_to_m - end interface + INTERFACE cp_f2m + MODULE PROCEDURE sm_matrix_transf_to_m + END INTERFACE !transfer from min basis to full basis - interface cp_m2f - module procedure sm_matrix_transf_to_f - end interface + INTERFACE cp_m2f + MODULE PROCEDURE sm_matrix_transf_to_f + END INTERFACE ! tranfser to full basis with B matrix pi - interface cp_m2f_with_B_M_pi - module procedure pao_m_m2f_with_b_m_pi - end interface + INTERFACE cp_m2f_with_B_M_pi + MODULE PROCEDURE pao_m_m2f_with_b_m_pi + END INTERFACE !!*** !**************************************************************************** -contains +CONTAINS !!****f* pao_types/pao_m_m2f_with_b_m_pi [1.0] * !! @@ -125,170 +146,170 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_m_m2f_with_b_m_pi(source_m, target_m, glob_angles,& + SUBROUTINE pao_m_m2f_with_b_m_pi(source_m, target_m, glob_angles,& qs_env, global_env, error) - type(real_matrix_type), pointer :: source_m ! make target? - type(real_matrix_type), pointer :: target_m ! make target? - type(pao_glob_angles_type), intent(in) :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - type(cp_error_type), optional, intent(inout) :: error + TYPE(real_matrix_type), POINTER :: source_m ! make target? + TYPE(real_matrix_type), POINTER :: target_m ! make target? + TYPE(pao_glob_angles_type), INTENT(in) :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineP='pao_types:pao_m_m2f_with_b_m_pi' - type(cp_matrix_block_iterator) :: iterator - integer :: brow,bcol, stat, max_bsize,i,j - integer, dimension(:), pointer :: l_index - real(kind=wp), dimension(:,:), pointer :: block_val, u_row - real(kind=wp),allocatable, dimension(:,:) :: t1_m - type(pao_local_angles_type) :: l_angles_col, l_angles_row - type(cp_error_type) :: iError - type(pao_env_type), pointer :: pao_env - call cp_error_init(iError,template_error=error) - nullify(block_val,l_index,u_row,pao_env) - failure=.false. + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineP='pao_types:pao_m_m2f_with_b_m_pi' + TYPE(cp_matrix_block_iterator) :: iterator + INTEGER :: brow,bcol, stat, max_bsize,i,j + INTEGER, DIMENSION(:), POINTER :: l_index + REAL(kind=wp), DIMENSION(:,:), POINTER :: block_val, u_row + REAL(kind=wp),ALLOCATABLE, DIMENSION(:,:) :: t1_m + TYPE(pao_local_angles_type) :: l_angles_col, l_angles_row + TYPE(cp_error_type) :: iError + TYPE(pao_env_type), POINTER :: pao_env + CALL cp_error_init(iError,template_error=error) + NULLIFY(block_val,l_index,u_row,pao_env) + failure=.FALSE. CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - call cp_init(l_angles_col,atom_nr=1, & + IF (.NOT. failure) THEN + CALL cp_init(l_angles_col,atom_nr=1, & glob_angles=glob_angles, qs_env=qs_env, global_env=global_env,& error=error) - call cp_init(l_angles_row,atom_nr=1, & + CALL cp_init(l_angles_row,atom_nr=1, & glob_angles=glob_angles, qs_env=qs_env, global_env=global_env,& error=error) - call pao_qs_env_get(qs_env,global_env=global_env, & + CALL pao_qs_env_get(qs_env,global_env=global_env, & pao_max_full_bas=max_bsize) - allocate(t1_m(max_bsize,max_bsize), stat=stat) + ALLOCATE(t1_m(max_bsize,max_bsize), stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - call cp_init(iterator,source_m,error=iError) - call cp_error_propagate_error(iError,routineP,& + CALL cp_init(iterator,source_m,error=iError) + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure) - if (.not.failure) then - blocksDo: do - if ((.not.cp_next(iterator,error=error)).or.failure) exit - call cp_get(iterator,block_row=brow,block_col=bcol,& + IF (.not.failure) THEN + blocksDo: DO + IF ((.not.cp_next(iterator,error=error)).or.failure) EXIT + CALL cp_get(iterator,block_row=brow,block_col=bcol,& block_val=block_val) ! get u - call cp_set(l_angles_col, atom_nr=bcol,error=error) - call cp_get(l_angles_col, proj_indexes=l_index) - call cp_set(l_angles_row, atom_nr=brow,error=error) - call cp_get(l_angles_row,NUi_injection=u_row) + CALL cp_set(l_angles_col, atom_nr=bcol,error=error) + CALL cp_get(l_angles_col, proj_indexes=l_index) + CALL cp_set(l_angles_row, atom_nr=brow,error=error) + CALL cp_get(l_angles_row,NUi_injection=u_row) ! t1_m = block_val pi t1_m=0.0_wp - CPPrecondition(associated(l_index),cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_assert(size(l_index)==size(block_val,2),& + CPPrecondition(ASSOCIATED(l_index),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN + CALL cp_assert(SIZE(l_index)==SIZE(block_val,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(block_val,1)==size(u_row,2),& + CALL cp_assert(SIZE(block_val,1)==SIZE(u_row,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if - if (.not.failure) then ! t1_m = block_val pi - do j=1,size(block_val,2) - do i=1,size(block_val,1) + END IF + IF (.not.failure) THEN ! t1_m = block_val pi + DO j=1,SIZE(block_val,2) + DO i=1,SIZE(block_val,1) t1_m(i,l_index(j))=block_val(i,j) - end do - end do - end if + END DO + END DO + END IF ! get full basis block - call get_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - if (.not.associated(block_val)) then - call add_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - CPPostcondition(associated(block_val),cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then - call cp_assert(size(block_val,1)==size(u_row,1),& + CALL get_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + IF (.not.ASSOCIATED(block_val)) THEN + CALL add_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + CPPostcondition(ASSOCIATED(block_val),cp_failure_level,routineP,error,failure) + END IF + IF (.not.failure) THEN + CALL cp_assert(SIZE(block_val,1)==SIZE(u_row,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF ! block_val = NUi t1_m - if (.not.failure) then - call dgemm('N','N',size(u_row,1),size(block_val,2),& - size(u_row,2),1.0_wp,& - u_row,size(u_row,1),& - t1_m,size(t1_m,1),& - 0.0_wp,block_val,size(block_val,1)) - end if + IF (.not.failure) THEN + CALL dgemm('N','N',SIZE(u_row,1),SIZE(block_val,2),& + SIZE(u_row,2),1.0_wp,& + u_row,SIZE(u_row,1),& + t1_m,SIZE(t1_m,1),& + 0.0_wp,block_val,SIZE(block_val,1)) + END IF - if (brow /= bcol) then ! do the transposed block - call cp_get(iterator,block_row=bcol,block_col=brow,& + IF (brow /= bcol) THEN ! do the transposed block + CALL cp_get(iterator,block_row=bcol,block_col=brow,& block_val=block_val) ! get u - call cp_set(l_angles_col, atom_nr=bcol,error=error) - call cp_get(l_angles_col, proj_indexes=l_index) - call cp_set(l_angles_row, atom_nr=brow,error=error) - call cp_get(l_angles_row,NUi_injection=u_row) + CALL cp_set(l_angles_col, atom_nr=bcol,error=error) + CALL cp_get(l_angles_col, proj_indexes=l_index) + CALL cp_set(l_angles_row, atom_nr=brow,error=error) + CALL cp_get(l_angles_row,NUi_injection=u_row) ! t1_m = block_val pi t1_m=0.0_wp - CPPrecondition(associated(l_index),cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_assert(size(l_index)==size(block_val,1),& + CPPrecondition(ASSOCIATED(l_index),cp_failure_level,routineP,error,failure) + IF (.not.failure) THEN + CALL cp_assert(SIZE(l_index)==SIZE(block_val,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(block_val,2)==size(u_row,2),& + CALL cp_assert(SIZE(block_val,2)==SIZE(u_row,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if - if (.not.failure) then ! t1_m = block_val pi - do i=1,size(block_val,2) - do j=1,size(block_val,1) + END IF + IF (.not.failure) THEN ! t1_m = block_val pi + DO i=1,SIZE(block_val,2) + DO j=1,SIZE(block_val,1) t1_m(i,l_index(j))=block_val(j,i) - end do - end do - end if + END DO + END DO + END IF ! get full basis block - call get_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - if (.not.associated(block_val)) then - call add_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - CPPostcondition(associated(block_val),cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then - call cp_assert(size(block_val,1)==size(u_row,1),& + CALL get_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + IF (.not.ASSOCIATED(block_val)) THEN + CALL add_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + CPPostcondition(ASSOCIATED(block_val),cp_failure_level,routineP,error,failure) + END IF + IF (.not.failure) THEN + CALL cp_assert(SIZE(block_val,1)==SIZE(u_row,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF ! block_val = NUi t1_m - if (.not.failure) then - call dgemm('N','N',size(u_row,1),size(block_val,2),& - size(u_row,2),1.0_wp,& - u_row,size(u_row,1),& - t1_m,size(t1_m,1),& - 0.0_wp,block_val,size(block_val,1)) - end if - end if + IF (.not.failure) THEN + CALL dgemm('N','N',SIZE(u_row,1),SIZE(block_val,2),& + SIZE(u_row,2),1.0_wp,& + u_row,SIZE(u_row,1),& + t1_m,SIZE(t1_m,1),& + 0.0_wp,block_val,SIZE(block_val,1)) + END IF + END IF - end do blocksDo - end if - call cp_dealloc_ref(iterator,error=error) - call cp_dealloc_ref(l_angles_col,error=error) - call cp_dealloc_ref(l_angles_row,error=error) - deallocate(t1_m,stat=stat) ! just to be sure... + END DO blocksDo + END IF + CALL cp_dealloc_ref(iterator,error=error) + CALL cp_dealloc_ref(l_angles_col,error=error) + CALL cp_dealloc_ref(l_angles_row,error=error) + DEALLOCATE(t1_m,stat=stat) ! just to be sure... CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - call cp_error_dealloc_ref(iError,error=error) - end subroutine pao_m_m2f_with_b_m_pi + END IF + CALL cp_error_dealloc_ref(iError,error=error) + END SUBROUTINE pao_m_m2f_with_b_m_pi !*************************************************************************** @@ -329,119 +350,119 @@ contains !! none !! !!*** ********************************************************************** - subroutine sm_matrix_transf_to_f(source_m, target_m, glob_angles,& + SUBROUTINE sm_matrix_transf_to_f(source_m, target_m, glob_angles,& qs_env, global_env, error) - type(real_matrix_type), pointer :: source_m ! make target? - type(real_matrix_type), pointer :: target_m ! make target ? - type(pao_glob_angles_type), intent(in) :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - type(cp_error_type), optional, intent(inout) :: error + TYPE(real_matrix_type), POINTER :: source_m ! make target? + TYPE(real_matrix_type), POINTER :: target_m ! make target ? + TYPE(pao_glob_angles_type), INTENT(in) :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='sm_matrix_transf_to_f',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='sm_matrix_transf_to_f',& routineP=moduleN//':'//routineN - type(cp_matrix_block_iterator) :: iterator - integer :: brow,bcol, stat, max_bsize,i,j - real(kind=wp), dimension(:,:), pointer :: block_val, u_col, u_row - real(kind=wp),allocatable, dimension(:,:) :: t1_m - type(pao_local_angles_type) :: l_angles_col, l_angles_row - type(cp_error_type) :: iError - type(pao_env_type), pointer :: pao_env - call cp_error_init(iError,template_error=error) - nullify(block_val,u_col, u_row,pao_env) - failure=.false. + TYPE(cp_matrix_block_iterator) :: iterator + INTEGER :: brow,bcol, stat, max_bsize,i,j + REAL(kind=wp), DIMENSION(:,:), POINTER :: block_val, u_col, u_row + REAL(kind=wp),ALLOCATABLE, DIMENSION(:,:) :: t1_m + TYPE(pao_local_angles_type) :: l_angles_col, l_angles_row + TYPE(cp_error_type) :: iError + TYPE(pao_env_type), POINTER :: pao_env + CALL cp_error_init(iError,template_error=error) + NULLIFY(block_val,u_col, u_row,pao_env) + failure=.FALSE. CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_init(l_angles_col,atom_nr=1, & + IF (.not.failure) THEN + CALL cp_init(l_angles_col,atom_nr=1, & glob_angles=glob_angles, qs_env=qs_env, global_env=global_env,& error=error) - call cp_init(l_angles_row,atom_nr=1, & + CALL cp_init(l_angles_row,atom_nr=1, & glob_angles=glob_angles, qs_env=qs_env, global_env=global_env,& error=error) - call pao_qs_env_get(qs_env,global_env=global_env,& + CALL pao_qs_env_get(qs_env,global_env=global_env,& pao_max_full_bas=max_bsize) - allocate(t1_m(max_bsize,max_bsize), stat=stat) + ALLOCATE(t1_m(max_bsize,max_bsize), stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - call cp_init(iterator,source_m,error=iError) - call cp_error_propagate_error(iError,routineP,& + CALL cp_init(iterator,source_m,error=iError) + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure) - if (.not.failure) then - blocksDo: do - if ((.not.cp_next(iterator,error=error)).or.failure) exit - call cp_get(iterator,block_row=brow,block_col=bcol,& + IF (.not.failure) THEN + blocksDo: DO + IF ((.not.cp_next(iterator,error=error)).or.failure) EXIT + CALL cp_get(iterator,block_row=brow,block_col=bcol,& block_val=block_val) ! get u - call cp_set(l_angles_col, atom_nr=bcol,error=error) - call cp_get(l_angles_col,NUi_injection=u_col) - call cp_set(l_angles_row, atom_nr=brow,error=error) - call cp_get(l_angles_row,NUi_injection=u_row) + CALL cp_set(l_angles_col, atom_nr=bcol,error=error) + CALL cp_get(l_angles_col,NUi_injection=u_col) + CALL cp_set(l_angles_row, atom_nr=brow,error=error) + CALL cp_get(l_angles_row,NUi_injection=u_row) - if (.not.failure) then - call cp_assert(size(u_col,2)==size(block_val,2),& + IF (.not.failure) THEN + CALL cp_assert(SIZE(u_col,2)==SIZE(block_val,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(u_row,2)==size(block_val,1),& + CALL cp_assert(SIZE(u_row,2)==SIZE(block_val,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF ! t1_m = block_val (N U i)^* - if (.not.failure) then - call dgemm('N','T',size(block_val,1),size(u_col,1),& - size(u_col,2),1.0_wp,& - block_val,size(block_val,1),& - u_col,size(u_col,1),& - 0.0_wp,t1_m,size(t1_m,1)) + IF (.not.failure) THEN + CALL dgemm('N','T',SIZE(block_val,1),SIZE(u_col,1),& + SIZE(u_col,2),1.0_wp,& + block_val,SIZE(block_val,1),& + u_col,SIZE(u_col,1),& + 0.0_wp,t1_m,SIZE(t1_m,1)) ! get full basis block - call get_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - if (.not.associated(block_val)) then - call add_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - CPPostcondition(associated(block_val),cp_failure_level,routineP,error,failure) - end if - end if + CALL get_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + IF (.not.ASSOCIATED(block_val)) THEN + CALL add_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + CPPostcondition(ASSOCIATED(block_val),cp_failure_level,routineP,error,failure) + END IF + END IF - if (.not.failure) then - call cp_assert(size(u_col,1)==size(block_val,2),& + IF (.not.failure) THEN + CALL cp_assert(SIZE(u_col,1)==SIZE(block_val,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(u_row,1)==size(block_val,1),& + CALL cp_assert(SIZE(u_row,1)==SIZE(block_val,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF ! block_val = NUi t1_m - if (.not.failure) then - call dgemm('N','N',size(u_row,1),size(u_col,1),& - size(u_row,2),1.0_wp,& - u_row,size(u_row,1),& - t1_m,size(t1_m,1),& - 0.0_wp,block_val,size(block_val,1)) - end if + IF (.not.failure) THEN + CALL dgemm('N','N',SIZE(u_row,1),SIZE(u_col,1),& + SIZE(u_row,2),1.0_wp,& + u_row,SIZE(u_row,1),& + t1_m,SIZE(t1_m,1),& + 0.0_wp,block_val,SIZE(block_val,1)) + END IF - end do blocksDo - end if - call cp_dealloc_ref(iterator,error=error) - call cp_dealloc_ref(l_angles_col,error=error) - call cp_dealloc_ref(l_angles_row,error=error) - deallocate(t1_m,stat=stat) ! just to be sure... + END DO blocksDo + END IF + CALL cp_dealloc_ref(iterator,error=error) + CALL cp_dealloc_ref(l_angles_col,error=error) + CALL cp_dealloc_ref(l_angles_row,error=error) + DEALLOCATE(t1_m,stat=stat) ! just to be sure... CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - call cp_error_dealloc_ref(iError,error=error) - end subroutine sm_matrix_transf_to_f + END IF + CALL cp_error_dealloc_ref(iError,error=error) + END SUBROUTINE sm_matrix_transf_to_f !*************************************************************************** !!****f* pao_types/sm_matrix_transf_to_m [1.0] * @@ -481,115 +502,115 @@ contains !! none !! !!*** ********************************************************************** - subroutine sm_matrix_transf_to_m(source_m, target_m, glob_angles,& + SUBROUTINE sm_matrix_transf_to_m(source_m, target_m, glob_angles,& qs_env, global_env, error) - type(real_matrix_type), pointer :: source_m ! make target? - type(real_matrix_type), pointer :: target_m ! make target? - type(pao_glob_angles_type), intent(in) :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - type(cp_error_type), optional, intent(inout) :: error + TYPE(real_matrix_type), POINTER :: source_m ! make target? + TYPE(real_matrix_type), POINTER :: target_m ! make target? + TYPE(pao_glob_angles_type), INTENT(in) :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='sm_matrix_transf_to_m',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='sm_matrix_transf_to_m',& routineP=moduleN//':'//routineN - type(cp_matrix_block_iterator) :: iterator - integer :: brow,bcol, stat, max_bsize,i,j - real(kind=wp), dimension(:,:), pointer :: block_val, u_col, u_row - real(kind=wp),allocatable, dimension(:,:) :: t1_m - type(pao_local_angles_type) :: l_angles_col, l_angles_row - type(cp_error_type) :: iError - type(pao_env_type), pointer :: pao_env - call cp_error_init(iError,template_error=error) - nullify(block_val,block_val, u_col, u_row,pao_env) - failure=.false. + TYPE(cp_matrix_block_iterator) :: iterator + INTEGER :: brow,bcol, stat, max_bsize,i,j + REAL(kind=wp), DIMENSION(:,:), POINTER :: block_val, u_col, u_row + REAL(kind=wp),ALLOCATABLE, DIMENSION(:,:) :: t1_m + TYPE(pao_local_angles_type) :: l_angles_col, l_angles_row + TYPE(cp_error_type) :: iError + TYPE(pao_env_type), POINTER :: pao_env + CALL cp_error_init(iError,template_error=error) + NULLIFY(block_val,block_val, u_col, u_row,pao_env) + failure=.FALSE. CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_init(l_angles_col,atom_nr=1, & + IF (.not.failure) THEN + CALL cp_init(l_angles_col,atom_nr=1, & glob_angles=glob_angles, qs_env=qs_env, global_env=global_env,& error=error) - call cp_init(l_angles_row,atom_nr=1, & + CALL cp_init(l_angles_row,atom_nr=1, & glob_angles=glob_angles, qs_env=qs_env, global_env=global_env,& error=error) - call pao_qs_env_get(qs_env,global_env=global_env,& + CALL pao_qs_env_get(qs_env,global_env=global_env,& pao_max_full_bas=max_bsize) - allocate(t1_m(max_bsize,max_bsize), stat=stat) + ALLOCATE(t1_m(max_bsize,max_bsize), stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - call cp_init(iterator,source_m,error=iError) - call cp_error_propagate_error(iError,routineP,& + CALL cp_init(iterator,source_m,error=iError) + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure) - if (.not.failure) then - blocksDo: do - if ((.not.cp_next(iterator,error=error)).or.failure) exit - call cp_get(iterator,block_row=brow,block_col=bcol,& + IF (.not.failure) THEN + blocksDo: DO + IF ((.not.cp_next(iterator,error=error)).or.failure) EXIT + CALL cp_get(iterator,block_row=brow,block_col=bcol,& block_val=block_val) ! get u - call cp_set(l_angles_col, atom_nr=bcol,error=error) - call cp_get(l_angles_col,NUi_injection=u_col,error=error) - call cp_set(l_angles_row, atom_nr=brow,error=error) - call cp_get(l_angles_row,NUi_injection=u_row,error=error) + CALL cp_set(l_angles_col, atom_nr=bcol,error=error) + CALL cp_get(l_angles_col,NUi_injection=u_col,error=error) + CALL cp_set(l_angles_row, atom_nr=brow,error=error) + CALL cp_get(l_angles_row,NUi_injection=u_row,error=error) - if (.not.failure) then - call cp_assert(size(u_row,1)==size(block_val,1),& + IF (.not.failure) THEN + CALL cp_assert(SIZE(u_row,1)==SIZE(block_val,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(u_col,1)==size(block_val,2),& + CALL cp_assert(SIZE(u_col,1)==SIZE(block_val,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF ! t1_m = source NUi - call dgemm('N','N',size(block_val,1),size(u_col,2),& - size(u_col,1),1.0_wp,& - block_val,size(block_val,1),& - u_col,size(u_col,1),& - 0.0_wp,t1_m,size(t1_m,1)) + CALL dgemm('N','N',SIZE(block_val,1),SIZE(u_col,2),& + SIZE(u_col,1),1.0_wp,& + block_val,SIZE(block_val,1),& + u_col,SIZE(u_col,1),& + 0.0_wp,t1_m,SIZE(t1_m,1)) ! get small basis block - call get_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - if (.not.associated(block_val)) then - call add_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - CPPostcondition(associated(block_val),cp_failure_level,routineP,error,failure) - end if + CALL get_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + IF (.not.ASSOCIATED(block_val)) THEN + CALL add_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + CPPostcondition(ASSOCIATED(block_val),cp_failure_level,routineP,error,failure) + END IF - if (.not.failure) then - call cp_assert(size(u_row,2)==size(block_val,1),& + IF (.not.failure) THEN + CALL cp_assert(SIZE(u_row,2)==SIZE(block_val,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(u_col,2)==size(block_val,2),& + CALL cp_assert(SIZE(u_col,2)==SIZE(block_val,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF ! target_m = (NUi)^* t1_m - if (.not.failure) then - call dgemm('T','N',size(u_row,2),size(u_col,2),& - size(u_row,1),1.0_wp,& - u_row,size(u_row,1),& - t1_m,size(t1_m,1),& - 0.0_wp,block_val,size(block_val,1)) - end if + IF (.not.failure) THEN + CALL dgemm('T','N',SIZE(u_row,2),SIZE(u_col,2),& + SIZE(u_row,1),1.0_wp,& + u_row,SIZE(u_row,1),& + t1_m,SIZE(t1_m,1),& + 0.0_wp,block_val,SIZE(block_val,1)) + END IF - end do blocksDo - end if - call cp_dealloc_ref(iterator,error=error) - call cp_dealloc_ref(l_angles_col,error=error) - call cp_dealloc_ref(l_angles_row,error=error) - deallocate(t1_m,stat=stat) ! just to be sure... + END DO blocksDo + END IF + CALL cp_dealloc_ref(iterator,error=error) + CALL cp_dealloc_ref(l_angles_col,error=error) + CALL cp_dealloc_ref(l_angles_row,error=error) + DEALLOCATE(t1_m,stat=stat) ! just to be sure... CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - call cp_error_dealloc_ref(iError,error=error) - end subroutine sm_matrix_transf_to_m + END IF + CALL cp_error_dealloc_ref(iError,error=error) + END SUBROUTINE sm_matrix_transf_to_m !*************************************************************************** !!****f* pao_types/sm_matrix_transf_p_to_m [1.0] * @@ -629,153 +650,153 @@ contains !! none !! !!*** ********************************************************************** - subroutine sm_matrix_transf_p_to_m(source_m, target_m, glob_angles,& + SUBROUTINE sm_matrix_transf_p_to_m(source_m, target_m, glob_angles,& qs_env, global_env, error) - type(real_matrix_type), pointer :: source_m ! make target? - type(real_matrix_type), pointer :: target_m ! make target? - type(pao_glob_angles_type), intent(in) :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - type(cp_error_type), optional, intent(inout) :: error + TYPE(real_matrix_type), POINTER :: source_m ! make target? + TYPE(real_matrix_type), POINTER :: target_m ! make target? + TYPE(pao_glob_angles_type), INTENT(in) :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - character(len=*), parameter :: routineN='sm_matrix_transf_p_to_m',& + LOGICAL :: failure + CHARACTER(len=*), PARAMETER :: routineN='sm_matrix_transf_p_to_m',& routineP=moduleN//':'//routineN - type(cp_matrix_block_iterator) :: iterator - integer :: brow,bcol, stat, max_bsize,i,j - real(kind=wp), dimension(:,:), pointer :: block_val, u_col, u_row,& + TYPE(cp_matrix_block_iterator) :: iterator + INTEGER :: brow,bcol, stat, max_bsize,i,j + REAL(kind=wp), DIMENSION(:,:), POINTER :: block_val, u_col, u_row,& s_col,s_row - real(kind=wp),allocatable, dimension(:,:) :: t1_m,t2_m - type(pao_local_angles_type) :: l_angles_col, l_angles_row - type(real_matrix_p_type), dimension(:), pointer :: s - type(cp_error_type) :: iError - type(pao_env_type), pointer :: pao_env - call cp_error_init(iError,template_error=error) - nullify(block_val,block_val, u_col, u_row,pao_env) - failure=.false. + REAL(kind=wp),ALLOCATABLE, DIMENSION(:,:) :: t1_m,t2_m + TYPE(pao_local_angles_type) :: l_angles_col, l_angles_row + TYPE(real_matrix_p_type), DIMENSION(:), POINTER :: s + TYPE(cp_error_type) :: iError + TYPE(pao_env_type), POINTER :: pao_env + CALL cp_error_init(iError,template_error=error) + NULLIFY(block_val,block_val, u_col, u_row,pao_env) + failure=.FALSE. CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - if (.not.failure) then - call cp_init(l_angles_col,atom_nr=1, & + IF (.not.failure) THEN + CALL cp_init(l_angles_col,atom_nr=1, & glob_angles=glob_angles, qs_env=qs_env, global_env=global_env,& error=error) - call cp_init(l_angles_row,atom_nr=1, & + CALL cp_init(l_angles_row,atom_nr=1, & glob_angles=glob_angles, qs_env=qs_env, global_env=global_env,& error=error) - call get_qs_env(qs_env,s=s) - call pao_qs_env_get(qs_env,global_env=global_env,& + CALL get_qs_env(qs_env,s=s) + CALL pao_qs_env_get(qs_env,global_env=global_env,& pao_max_full_bas=max_bsize) - allocate(t1_m(max_bsize,max_bsize),t2_m(max_bsize,max_bsize), stat=stat) + ALLOCATE(t1_m(max_bsize,max_bsize),t2_m(max_bsize,max_bsize), stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - call cp_init(iterator,source_m,error=iError) - call cp_error_propagate_error(iError,routineP,& + CALL cp_init(iterator,source_m,error=iError) + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure) - if (.not.failure) then - blocksDo: do - if ((.not.cp_next(iterator,error=error)).or.failure) exit - call cp_get(iterator,block_row=brow,block_col=bcol,& + IF (.not.failure) THEN + blocksDo: DO + IF ((.not.cp_next(iterator,error=error)).or.failure) EXIT + CALL cp_get(iterator,block_row=brow,block_col=bcol,& block_val=block_val) ! get u - call cp_set(l_angles_col, atom_nr=bcol,error=error) - call cp_get(l_angles_col,NUi_injection=u_col,error=error) - call cp_set(l_angles_row, atom_nr=brow,error=error) - call cp_get(l_angles_row,NUi_injection=u_row,error=error) + CALL cp_set(l_angles_col, atom_nr=bcol,error=error) + CALL cp_get(l_angles_col,NUi_injection=u_col,error=error) + CALL cp_set(l_angles_row, atom_nr=brow,error=error) + CALL cp_get(l_angles_row,NUi_injection=u_row,error=error) - if (.not.failure) then - call cp_assert(size(u_row,1)==size(block_val,1),& + IF (.not.failure) THEN + CALL cp_assert(SIZE(u_row,1)==SIZE(block_val,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(u_col,1)==size(block_val,2),& + CALL cp_assert(SIZE(u_col,1)==SIZE(block_val,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF - call get_block_node(s(1)%matrix,block_row=bcol,block_col=bcol,& - block=s_col) - call get_block_node(s(1)%matrix,block_row=brow,block_col=brow,& - block=s_row) - if (.not.failure) then - call cp_assert(size(s_col,1)==size(block_val,2).and.& - size(s_col,1)==size(s_col,2),& + CALL get_block_node(s(1)%matrix,block_row=bcol,block_col=bcol,& + BLOCK=s_col) + CALL get_block_node(s(1)%matrix,block_row=brow,block_col=brow,& + BLOCK=s_row) + IF (.not.failure) THEN + CALL cp_assert(SIZE(s_col,1)==SIZE(block_val,2).AND.& + SIZE(s_col,1)==SIZE(s_col,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(s_row,2)==size(block_val,1).and.& - size(s_row,1)==size(s_row,2),& + CALL cp_assert(SIZE(s_row,2)==SIZE(block_val,1).AND.& + SIZE(s_row,1)==SIZE(s_row,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF ! t1_m = block_val S - if (.not.failure) then - call dgemm('N','N',size(block_val,1),size(block_val,2),& - size(block_val,2),1.0_wp,& - block_val,size(block_val,1),& - s_col,size(s_col,1),& - 0.0_wp,t1_m,size(t1_m,1)) - end if + IF (.not.failure) THEN + CALL dgemm('N','N',SIZE(block_val,1),SIZE(block_val,2),& + SIZE(block_val,2),1.0_wp,& + block_val,SIZE(block_val,1),& + s_col,SIZE(s_col,1),& + 0.0_wp,t1_m,SIZE(t1_m,1)) + END IF ! t2_m = S t1_m (could be partially faster if done later) - if (.not.failure) then - call dgemm('N','N',size(block_val,1),size(block_val,2),& - size(block_val,1),1.0_wp,& - s_row,size(s_row,1),& - t1_m,size(t1_m,1),& - 0.0_wp,t2_m,size(t2_m,1)) - end if + IF (.not.failure) THEN + CALL dgemm('N','N',SIZE(block_val,1),SIZE(block_val,2),& + SIZE(block_val,1),1.0_wp,& + s_row,SIZE(s_row,1),& + t1_m,SIZE(t1_m,1),& + 0.0_wp,t2_m,SIZE(t2_m,1)) + END IF ! t1_m = t2_m NUi - call dgemm('N','N',size(block_val,1),size(u_col,2),& - size(u_col,1),1.0_wp,& - t2_m,size(t2_m,1),& - u_col,size(u_col,1),& - 0.0_wp,t1_m,size(t1_m,1)) + CALL dgemm('N','N',SIZE(block_val,1),SIZE(u_col,2),& + SIZE(u_col,1),1.0_wp,& + t2_m,SIZE(t2_m,1),& + u_col,SIZE(u_col,1),& + 0.0_wp,t1_m,SIZE(t1_m,1)) ! get small basis block - call get_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - if (.not.associated(block_val)) then - call add_block_node(target_m, block_col=bcol,& - block_row=brow, block=block_val) - CPPostcondition(associated(block_val),cp_failure_level,routineP,error,failure) - end if + CALL get_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + IF (.not.ASSOCIATED(block_val)) THEN + CALL add_block_node(target_m, block_col=bcol,& + block_row=brow, BLOCK=block_val) + CPPostcondition(ASSOCIATED(block_val),cp_failure_level,routineP,error,failure) + END IF - if (.not.failure) then - call cp_assert(size(u_row,2)==size(block_val,1),& + IF (.not.failure) THEN + CALL cp_assert(SIZE(u_row,2)==SIZE(block_val,1),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - call cp_assert(size(u_col,2)==size(block_val,2),& + CALL cp_assert(SIZE(u_col,2)==SIZE(block_val,2),& cp_failure_level,cp_precondition_failed,routineP,& "size mishmash in "//& CPSourceFileRef,& error,failure) - end if + END IF ! target_m = (NUi)^* t1_m - if (.not.failure) then - call dgemm('T','N',size(u_row,2),size(u_col,2),& - size(u_row,1),1.0_wp,& - u_row,size(u_row,1),& - t1_m,size(t1_m,1),& - 0.0_wp,block_val,size(block_val,1)) - end if + IF (.not.failure) THEN + CALL dgemm('T','N',SIZE(u_row,2),SIZE(u_col,2),& + SIZE(u_row,1),1.0_wp,& + u_row,SIZE(u_row,1),& + t1_m,SIZE(t1_m,1),& + 0.0_wp,block_val,SIZE(block_val,1)) + END IF - end do blocksDo - end if - call cp_dealloc_ref(iterator,error=error) - call cp_dealloc_ref(l_angles_col,error=error) - call cp_dealloc_ref(l_angles_row,error=error) - deallocate(t1_m,stat=stat) ! just to be sure... + END DO blocksDo + END IF + CALL cp_dealloc_ref(iterator,error=error) + CALL cp_dealloc_ref(l_angles_col,error=error) + CALL cp_dealloc_ref(l_angles_row,error=error) + DEALLOCATE(t1_m,stat=stat) ! just to be sure... CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) - end if - call cp_error_dealloc_ref(iError,error=error) - end subroutine sm_matrix_transf_p_to_m + END IF + CALL cp_error_dealloc_ref(iError,error=error) + END SUBROUTINE sm_matrix_transf_p_to_m !*************************************************************************** !!****f* pao_proj_methods/pao_g_ang_get_min_m [1.0] * @@ -820,90 +841,90 @@ contains !! none !! !!*** ********************************************************************** - subroutine pao_g_ang_get_min_m(glob_angles,qs_env,global_env,& + SUBROUTINE pao_g_ang_get_min_m(glob_angles,qs_env,global_env,& min_overlap_m, min_hamiltonian_m, error) - type(pao_glob_angles_type), intent(inout) :: glob_angles - type(qs_environment_type), intent(in), target :: qs_env - type(global_environment_type), intent(in), target :: global_env - type(cp_block_matrix_p_type), dimension(:), pointer, optional :: & + TYPE(pao_glob_angles_type), INTENT(inout) :: glob_angles + TYPE(qs_environment_type), INTENT(in), TARGET :: qs_env + TYPE(global_environment_type), INTENT(in), TARGET :: global_env + TYPE(cp_block_matrix_p_type), DIMENSION(:), POINTER, OPTIONAL :: & min_hamiltonian_m - type(cp_block_matrix_p_type), dimension(:), pointer :: min_overlap_m - type(cp_error_type), optional, intent(inout) :: error + TYPE(cp_block_matrix_p_type), DIMENSION(:), POINTER :: min_overlap_m + TYPE(cp_error_type), OPTIONAL, INTENT(inout) :: error - logical :: failure - integer :: handle, stat - character(len=*), parameter :: routineN='pao_g_ang_get_min_m',& + LOGICAL :: failure + INTEGER :: handle, stat + CHARACTER(len=*), PARAMETER :: routineN='pao_g_ang_get_min_m',& routineP=moduleN//':'//routineN - type(cp_error_type) :: iError - type(real_matrix_p_type), dimension(:), pointer :: full_h, full_s - type(cp_b_matrix_struct_type), pointer :: min_bas_m_struct, & + TYPE(cp_error_type) :: iError + TYPE(real_matrix_p_type), DIMENSION(:), POINTER :: full_h, full_s + TYPE(cp_b_matrix_struct_type), POINTER :: min_bas_m_struct, & full_bas_m_struct - type(pao_env_type), pointer :: pao_env - call cp_error_init(iError, template_error=error) - failure=.false. - nullify(full_h, full_s, pao_env) + TYPE(pao_env_type), POINTER :: pao_env + CALL cp_error_init(iError, template_error=error) + failure=.FALSE. + NULLIFY(full_h, full_s, pao_env) !call timeset(routineN//','//moduleN,'I',"",handle) CPPrecondition(glob_angles%initialized,cp_failure_level,routineP,error,failure) - if (.not. failure) then - call get_qs_env(qs_env,k=full_h,s=full_s,pao_env=pao_env) - CPPrecondition(associated(pao_env),cp_failure_level,routineP,error,failure) - end if - if (.not.failure) then - call pao_env_get(pao_env,min_bas_m_struct=min_bas_m_struct,& + IF (.NOT. failure) THEN + CALL get_qs_env(qs_env,k=full_h,s=full_s,pao_env=pao_env) + CPPrecondition(ASSOCIATED(pao_env),cp_failure_level,routineP,error,failure) + END IF + IF (.not.failure) THEN + CALL pao_env_get(pao_env,min_bas_m_struct=min_bas_m_struct,& full_bas_diag_m_struct=full_bas_m_struct,error=error) ! if (present(min_overlap_m)) then - if (.not.glob_angles%m_s_m_valid) then - if (.not.associated(glob_angles%min_overlap_m)) then - allocate(glob_angles%min_overlap_m(1),stat=stat) + IF (.not.glob_angles%m_s_m_valid) THEN + IF (.not.ASSOCIATED(glob_angles%min_overlap_m)) THEN + ALLOCATE(glob_angles%min_overlap_m(1),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - call cp_sp_create(glob_angles%min_overlap_m(1)%matrix,& + CALL cp_sp_create(glob_angles%min_overlap_m(1)%matrix,& matrix_struct=min_bas_m_struct,& error=iError) - end if - call sm_matrix_transf_to_m(source_m=full_s(1)%matrix, & + END IF + CALL sm_matrix_transf_to_m(source_m=full_s(1)%matrix, & target_m=glob_angles%min_overlap_m(1)%matrix%sm,& glob_angles=glob_angles,qs_env=qs_env,& global_env=global_env,error=error) - glob_angles%m_s_m_valid=.true. - end if - CPAssert(associated(glob_angles%min_overlap_m),cp_failure_level,routineP,error,failure) - if (glob_angles%m_s_m_valid) then + glob_angles%m_s_m_valid=.TRUE. + END IF + CPAssert(ASSOCIATED(glob_angles%min_overlap_m),cp_failure_level,routineP,error,failure) + IF (glob_angles%m_s_m_valid) THEN min_overlap_m => glob_angles%min_overlap_m - else - nullify(min_overlap_m) - end if + ELSE + NULLIFY(min_overlap_m) + END IF ! end if - if (present(min_hamiltonian_m)) then - if (.not.glob_angles%m_h_m_valid) then - if (.not.associated(glob_angles%min_hamiltonian_m)) then - allocate(glob_angles%min_hamiltonian_m(1),stat=stat) + IF (PRESENT(min_hamiltonian_m)) THEN + IF (.not.glob_angles%m_h_m_valid) THEN + IF (.not.ASSOCIATED(glob_angles%min_hamiltonian_m)) THEN + ALLOCATE(glob_angles%min_hamiltonian_m(1),stat=stat) CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) - call cp_sp_create(glob_angles%min_hamiltonian_m(1)%matrix, & + CALL cp_sp_create(glob_angles%min_hamiltonian_m(1)%matrix, & matrix_struct=min_bas_m_struct,& error=iError) - call cp_error_propagate_error(iError,routineP,& + CALL cp_error_propagate_error(iError,routineP,& CPSourceFileRef,& error,failure) - end if - if (.not.failure) then - call sm_matrix_transf_to_m(source_m=full_h(1)%matrix,& + END IF + IF (.not.failure) THEN + CALL sm_matrix_transf_to_m(source_m=full_h(1)%matrix,& target_m=glob_angles%min_hamiltonian_m(1)%matrix%sm,& glob_angles=glob_angles,qs_env=qs_env,& global_env=global_env,error=error) - glob_angles%m_h_m_valid=.true. - end if - end if - CPAssert(associated(glob_angles%min_overlap_m),cp_failure_level,routineP,error,failure) - if (glob_angles%m_h_m_valid) then + glob_angles%m_h_m_valid=.TRUE. + END IF + END IF + CPAssert(ASSOCIATED(glob_angles%min_overlap_m),cp_failure_level,routineP,error,failure) + IF (glob_angles%m_h_m_valid) THEN min_hamiltonian_m => glob_angles%min_hamiltonian_m - else - nullify(min_hamiltonian_m) - end if - end if - end if + ELSE + NULLIFY(min_hamiltonian_m) + END IF + END IF + END IF !call timestop(0.0_wp,handle) - end subroutine pao_g_ang_get_min_m + END SUBROUTINE pao_g_ang_get_min_m !*************************************************************************** -end module pao_proj_methods +END MODULE pao_proj_methods diff --git a/src/pao_types.F b/src/pao_types.F index 0d479f0173..0ae6dbad1b 100644 --- a/src/pao_types.F +++ b/src/pao_types.F @@ -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 diff --git a/src/pao_utils.F b/src/pao_utils.F index 3dcc133602..8309180813 100644 --- a/src/pao_utils.F +++ b/src/pao_utils.F @@ -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 (restoi) res=toi + IF (res