From 8d489f8ce24c295a2bb7c2ca0f254e161c9545bb Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 10 Dec 2018 11:42:40 +0000 Subject: [PATCH] Merged MixedI8 in new branch (to be later merged into development) --- Changelog | 1 + base/comm/Makefile | 19 +- base/comm/internals/Makefile | 18 +- base/comm/internals/psi_covrl_restr.f90 | 97 +- base/comm/internals/psi_covrl_restr_a.f90 | 124 + base/comm/internals/psi_covrl_save.f90 | 110 +- base/comm/internals/psi_covrl_save_a.f90 | 135 + base/comm/internals/psi_covrl_upd.f90 | 141 +- base/comm/internals/psi_covrl_upd_a.f90 | 167 + base/comm/internals/psi_cswapdata.F90 | 951 +- base/comm/internals/psi_cswapdata_a.F90 | 988 ++ base/comm/internals/psi_cswaptran.F90 | 968 +- base/comm/internals/psi_cswaptran_a.F90 | 1004 ++ base/comm/internals/psi_dovrl_restr.f90 | 97 +- base/comm/internals/psi_dovrl_restr_a.f90 | 124 + base/comm/internals/psi_dovrl_save.f90 | 110 +- base/comm/internals/psi_dovrl_save_a.f90 | 135 + base/comm/internals/psi_dovrl_upd.f90 | 141 +- base/comm/internals/psi_dovrl_upd_a.f90 | 167 + base/comm/internals/psi_dswapdata.F90 | 951 +- base/comm/internals/psi_dswapdata_a.F90 | 988 ++ base/comm/internals/psi_dswaptran.F90 | 968 +- base/comm/internals/psi_dswaptran_a.F90 | 1004 ++ base/comm/internals/psi_eovrl_restr_a.f90 | 124 + base/comm/internals/psi_eovrl_save_a.f90 | 135 + base/comm/internals/psi_eovrl_upd_a.f90 | 167 + base/comm/internals/psi_eswapdata_a.F90 | 988 ++ base/comm/internals/psi_eswaptran_a.F90 | 1004 ++ base/comm/internals/psi_iovrl_restr.f90 | 97 +- base/comm/internals/psi_iovrl_save.f90 | 110 +- base/comm/internals/psi_iovrl_upd.f90 | 141 +- base/comm/internals/psi_iswapdata.F90 | 959 +- base/comm/internals/psi_iswaptran.F90 | 976 +- base/comm/internals/psi_lovrl_restr.f90 | 115 + base/comm/internals/psi_lovrl_save.f90 | 129 + base/comm/internals/psi_lovrl_upd.f90 | 194 + base/comm/internals/psi_lswapdata.F90 | 766 ++ base/comm/internals/psi_lswaptran.F90 | 787 ++ base/comm/internals/psi_movrl_restr_a.f90 | 124 + base/comm/internals/psi_movrl_save_a.f90 | 135 + base/comm/internals/psi_movrl_upd_a.f90 | 167 + base/comm/internals/psi_mswapdata_a.F90 | 988 ++ base/comm/internals/psi_mswaptran_a.F90 | 1004 ++ base/comm/internals/psi_sovrl_restr.f90 | 97 +- base/comm/internals/psi_sovrl_restr_a.f90 | 124 + base/comm/internals/psi_sovrl_save.f90 | 110 +- base/comm/internals/psi_sovrl_save_a.f90 | 135 + base/comm/internals/psi_sovrl_upd.f90 | 141 +- base/comm/internals/psi_sovrl_upd_a.f90 | 167 + base/comm/internals/psi_sswapdata.F90 | 951 +- base/comm/internals/psi_sswapdata_a.F90 | 988 ++ base/comm/internals/psi_sswaptran.F90 | 968 +- base/comm/internals/psi_sswaptran_a.F90 | 1004 ++ base/comm/internals/psi_zovrl_restr.f90 | 97 +- base/comm/internals/psi_zovrl_restr_a.f90 | 124 + base/comm/internals/psi_zovrl_save.f90 | 110 +- base/comm/internals/psi_zovrl_save_a.f90 | 135 + base/comm/internals/psi_zovrl_upd.f90 | 141 +- base/comm/internals/psi_zovrl_upd_a.f90 | 167 + base/comm/internals/psi_zswapdata.F90 | 951 +- base/comm/internals/psi_zswapdata_a.F90 | 988 ++ base/comm/internals/psi_zswaptran.F90 | 968 +- base/comm/internals/psi_zswaptran_a.F90 | 1004 ++ base/comm/psb_cgather.f90 | 305 +- base/comm/psb_cgather_a.f90 | 335 + base/comm/psb_chalo.f90 | 363 +- base/comm/psb_chalo_a.f90 | 398 + base/comm/psb_covrl.f90 | 340 +- base/comm/psb_covrl_a.f90 | 384 + base/comm/psb_cscatter.F90 | 456 +- base/comm/psb_cscatter_a.F90 | 480 + base/comm/psb_cspgather.F90 | 359 +- base/comm/psb_dgather.f90 | 305 +- base/comm/psb_dgather_a.f90 | 335 + base/comm/psb_dhalo.f90 | 363 +- base/comm/psb_dhalo_a.f90 | 398 + base/comm/psb_dovrl.f90 | 340 +- base/comm/psb_dovrl_a.f90 | 384 + base/comm/psb_dscatter.F90 | 456 +- base/comm/psb_dscatter_a.F90 | 480 + base/comm/psb_dspgather.F90 | 359 +- base/comm/psb_egather_a.f90 | 335 + base/comm/psb_ehalo_a.f90 | 398 + base/comm/psb_eovrl_a.f90 | 384 + base/comm/psb_escatter_a.F90 | 480 + base/comm/psb_igather.f90 | 305 +- base/comm/psb_ihalo.f90 | 363 +- base/comm/psb_iovrl.f90 | 340 +- base/comm/psb_iscatter.F90 | 456 +- base/comm/psb_ispgather.F90 | 483 + base/comm/psb_lgather.f90 | 274 + base/comm/psb_lhalo.f90 | 336 + base/comm/psb_lovrl.f90 | 318 + base/comm/psb_lscatter.F90 | 99 + base/comm/psb_lspgather.F90 | 483 + base/comm/psb_mgather_a.f90 | 335 + base/comm/psb_mhalo_a.f90 | 398 + base/comm/psb_movrl_a.f90 | 384 + base/comm/psb_mscatter_a.F90 | 480 + base/comm/psb_sgather.f90 | 305 +- base/comm/psb_sgather_a.f90 | 335 + base/comm/psb_shalo.f90 | 363 +- base/comm/psb_shalo_a.f90 | 398 + base/comm/psb_sovrl.f90 | 340 +- base/comm/psb_sovrl_a.f90 | 384 + base/comm/psb_sscatter.F90 | 456 +- base/comm/psb_sscatter_a.F90 | 480 + base/comm/psb_sspgather.F90 | 359 +- base/comm/psb_zgather.f90 | 305 +- base/comm/psb_zgather_a.f90 | 335 + base/comm/psb_zhalo.f90 | 363 +- base/comm/psb_zhalo_a.f90 | 398 + base/comm/psb_zovrl.f90 | 340 +- base/comm/psb_zovrl_a.f90 | 384 + base/comm/psb_zscatter.F90 | 456 +- base/comm/psb_zscatter_a.F90 | 480 + base/comm/psb_zspgather.F90 | 359 +- base/internals/psb_indx_map_fnd_owner.F90 | 34 +- base/internals/psi_bld_tmphalo.f90 | 3 +- base/internals/psi_bld_tmpovrl.f90 | 11 +- base/internals/psi_crea_bnd_elem.f90 | 35 +- base/internals/psi_crea_index.f90 | 8 +- base/internals/psi_crea_ovr_elem.f90 | 10 +- base/internals/psi_desc_impl.f90 | 40 +- base/internals/psi_desc_index.F90 | 22 +- base/internals/psi_dl_check.f90 | 6 +- base/internals/psi_extrct_dl.F90 | 15 +- base/internals/psi_fnd_owner.F90 | 2 +- base/internals/psi_sort_dl.f90 | 6 +- base/modules/Makefile | 325 +- base/modules/README.F2003 | 78 +- base/modules/aux/psb_ip_reord_mod.f90 | 670 -- base/modules/auxil/psb_c_hsort_mod.f90 | 125 + base/modules/auxil/psb_c_hsort_x_mod.f90 | 308 + base/modules/auxil/psb_c_ip_reord_mod.F90 | 320 + base/modules/auxil/psb_c_isort_mod.f90 | 127 + base/modules/auxil/psb_c_msort_mod.f90 | 121 + base/modules/auxil/psb_c_qsort_mod.f90 | 126 + base/modules/auxil/psb_c_realloc_mod.F90 | 1027 ++ .../modules/{aux => auxil}/psb_c_sort_mod.f90 | 5 +- base/modules/auxil/psb_d_hsort_mod.f90 | 125 + base/modules/auxil/psb_d_hsort_x_mod.f90 | 308 + base/modules/auxil/psb_d_ip_reord_mod.F90 | 320 + base/modules/auxil/psb_d_isort_mod.f90 | 105 + base/modules/auxil/psb_d_msort_mod.f90 | 104 + base/modules/auxil/psb_d_qsort_mod.f90 | 123 + base/modules/auxil/psb_d_realloc_mod.F90 | 1027 ++ .../modules/{aux => auxil}/psb_d_sort_mod.f90 | 5 +- base/modules/auxil/psb_e_hsort_mod.f90 | 125 + base/modules/auxil/psb_e_ip_reord_mod.F90 | 320 + base/modules/auxil/psb_e_isort_mod.f90 | 105 + base/modules/auxil/psb_e_msort_mod.f90 | 111 + base/modules/auxil/psb_e_qsort_mod.f90 | 123 + base/modules/auxil/psb_e_realloc_mod.F90 | 1027 ++ base/modules/auxil/psb_i_hsort_x_mod.f90 | 309 + .../modules/{aux => auxil}/psb_i_sort_mod.f90 | 10 +- .../psb_ip_reord_mod.F90} | 34 +- base/modules/auxil/psb_l_hsort_x_mod.f90 | 309 + base/modules/auxil/psb_l_sort_mod.f90 | 578 ++ base/modules/auxil/psb_m_hsort_mod.f90 | 125 + base/modules/auxil/psb_m_ip_reord_mod.F90 | 320 + base/modules/auxil/psb_m_isort_mod.f90 | 105 + base/modules/auxil/psb_m_msort_mod.f90 | 111 + base/modules/auxil/psb_m_qsort_mod.f90 | 123 + base/modules/auxil/psb_m_realloc_mod.F90 | 1027 ++ base/modules/auxil/psb_s_hsort_mod.f90 | 125 + base/modules/auxil/psb_s_hsort_x_mod.f90 | 308 + base/modules/auxil/psb_s_ip_reord_mod.F90 | 320 + base/modules/auxil/psb_s_isort_mod.f90 | 105 + base/modules/auxil/psb_s_msort_mod.f90 | 104 + base/modules/auxil/psb_s_qsort_mod.f90 | 123 + base/modules/auxil/psb_s_realloc_mod.F90 | 1027 ++ .../modules/{aux => auxil}/psb_s_sort_mod.f90 | 5 +- base/modules/auxil/psb_sort_mod.f90 | 86 + .../modules/{aux => auxil}/psb_string_mod.f90 | 0 base/modules/auxil/psb_z_hsort_mod.f90 | 125 + base/modules/auxil/psb_z_hsort_x_mod.f90 | 308 + base/modules/auxil/psb_z_ip_reord_mod.F90 | 320 + base/modules/auxil/psb_z_isort_mod.f90 | 127 + base/modules/auxil/psb_z_msort_mod.f90 | 121 + base/modules/auxil/psb_z_qsort_mod.f90 | 126 + base/modules/auxil/psb_z_realloc_mod.F90 | 1027 ++ .../modules/{aux => auxil}/psb_z_sort_mod.f90 | 5 +- .../{aux => auxil}/psi_c_serial_mod.f90 | 2 +- .../{aux => auxil}/psi_d_serial_mod.f90 | 2 +- .../psi_e_serial_mod.f90} | 110 +- base/modules/auxil/psi_m_serial_mod.f90 | 133 + .../{aux => auxil}/psi_s_serial_mod.f90 | 2 +- .../modules/{aux => auxil}/psi_serial_mod.f90 | 3 +- .../{aux => auxil}/psi_z_serial_mod.f90 | 2 +- base/modules/comm/psb_base_linmap_mod.f90 | 10 +- base/modules/comm/psb_c_comm_a_mod.f90 | 122 + base/modules/comm/psb_c_comm_mod.f90 | 88 +- base/modules/comm/psb_c_linmap_mod.f90 | 26 +- base/modules/comm/psb_comm_mod.f90 | 8 + base/modules/comm/psb_d_comm_a_mod.f90 | 122 + base/modules/comm/psb_d_comm_mod.f90 | 88 +- base/modules/comm/psb_d_linmap_mod.f90 | 26 +- base/modules/comm/psb_e_comm_a_mod.f90 | 122 + base/modules/comm/psb_i_comm_mod.f90 | 76 +- base/modules/comm/psb_l_comm_mod.f90 | 117 + base/modules/comm/psb_m_comm_a_mod.f90 | 122 + base/modules/comm/psb_s_comm_a_mod.f90 | 122 + base/modules/comm/psb_s_comm_mod.f90 | 88 +- base/modules/comm/psb_s_linmap_mod.f90 | 26 +- base/modules/comm/psb_z_comm_a_mod.f90 | 122 + base/modules/comm/psb_z_comm_mod.f90 | 88 +- base/modules/comm/psb_z_linmap_mod.f90 | 26 +- base/modules/comm/psi_c_comm_a_mod.f90 | 166 + .../psi_c_comm_v_mod.f90} | 119 +- base/modules/comm/psi_d_comm_a_mod.f90 | 166 + .../psi_d_comm_v_mod.f90} | 119 +- base/modules/comm/psi_e_comm_a_mod.f90 | 166 + base/modules/comm/psi_i_comm_v_mod.f90 | 180 + base/modules/comm/psi_l_comm_v_mod.f90 | 181 + base/modules/comm/psi_m_comm_a_mod.f90 | 166 + base/modules/comm/psi_s_comm_a_mod.f90 | 166 + .../psi_s_comm_v_mod.f90} | 119 +- base/modules/comm/psi_z_comm_a_mod.f90 | 166 + .../psi_z_comm_v_mod.f90} | 119 +- base/modules/desc/psb_desc_const_mod.f90 | 14 +- base/modules/desc/psb_desc_mod.F90 | 207 +- base/modules/desc/psb_gen_block_map_mod.f90 | 1257 ++- base/modules/desc/psb_glist_map_mod.f90 | 17 +- base/modules/desc/psb_hash_map_mod.f90 | 313 +- .../psb_hash_mod.F90} | 259 +- base/modules/desc/psb_hashval.c | 49 + base/modules/desc/psb_indx_map_mod.f90 | 446 +- base/modules/desc/psb_list_map_mod.f90 | 673 +- base/modules/desc/psb_repl_map_mod.f90 | 128 +- base/modules/error.f90 | 2 +- base/modules/penv/psi_c_collective_mod.F90 | 744 ++ base/modules/penv/psi_c_p2p_mod.F90 | 307 + base/modules/penv/psi_collective_mod.F90 | 420 + .../{ => penv}/psi_comm_buffers_mod.F90 | 234 +- base/modules/penv/psi_d_collective_mod.F90 | 1235 +++ base/modules/penv/psi_d_p2p_mod.F90 | 307 + base/modules/penv/psi_e_collective_mod.F90 | 1112 +++ base/modules/penv/psi_e_p2p_mod.F90 | 307 + base/modules/penv/psi_m_collective_mod.F90 | 1112 +++ base/modules/penv/psi_m_p2p_mod.F90 | 307 + base/modules/penv/psi_p2p_mod.F90 | 418 + base/modules/{ => penv}/psi_penv_mod.F90 | 287 +- base/modules/penv/psi_s_collective_mod.F90 | 1235 +++ base/modules/penv/psi_s_p2p_mod.F90 | 307 + base/modules/penv/psi_z_collective_mod.F90 | 744 ++ base/modules/penv/psi_z_p2p_mod.F90 | 307 + base/modules/psb_cbind_const_mod.F90 | 52 + base/modules/psb_check_mod.f90 | 8 +- base/modules/psb_const_mod.F90 | 138 +- base/modules/psb_error_impl.F90 | 64 +- base/modules/psb_error_mod.F90 | 250 +- base/modules/psb_penv_mod.F90 | 5 +- base/modules/psb_realloc_mod.F90 | 3587 +------ base/modules/psi_bcast_mod.F90 | 1002 -- base/modules/psi_c_mod.F90 | 41 + base/modules/psi_d_mod.F90 | 41 + base/modules/psi_i_mod.F90 | 225 + base/modules/psi_i_mod.f90 | 453 - base/modules/psi_l_mod.F90 | 42 + base/modules/psi_mod.f90 | 1 + base/modules/psi_p2p_mod.F90 | 2348 ----- base/modules/psi_reduce_mod.F90 | 5589 ----------- base/modules/psi_s_mod.F90 | 41 + base/modules/psi_z_mod.F90 | 41 + base/modules/serial/psb_base_mat_mod.f90 | 901 +- base/modules/serial/psb_c_base_mat_mod.f90 | 2105 ++++- base/modules/serial/psb_c_base_vect_mod.f90 | 84 +- base/modules/serial/psb_c_csc_mat_mod.f90 | 628 +- base/modules/serial/psb_c_csr_mat_mod.f90 | 680 +- base/modules/serial/psb_c_mat_mod.F90 | 2740 ++++++ base/modules/serial/psb_c_mat_mod.f90 | 1296 --- base/modules/serial/psb_c_serial_mod.f90 | 91 +- base/modules/serial/psb_c_vect_mod.F90 | 39 +- base/modules/serial/psb_d_base_mat_mod.f90 | 2105 ++++- base/modules/serial/psb_d_base_vect_mod.f90 | 84 +- base/modules/serial/psb_d_csc_mat_mod.f90 | 628 +- base/modules/serial/psb_d_csr_mat_mod.f90 | 680 +- base/modules/serial/psb_d_mat_mod.F90 | 2740 ++++++ base/modules/serial/psb_d_mat_mod.f90 | 1296 --- base/modules/serial/psb_d_serial_mod.f90 | 91 +- base/modules/serial/psb_d_vect_mod.F90 | 39 +- base/modules/serial/psb_i_base_vect_mod.f90 | 83 +- base/modules/serial/psb_i_vect_mod.F90 | 39 +- base/modules/serial/psb_l_base_vect_mod.f90 | 1858 ++++ base/modules/serial/psb_l_vect_mod.F90 | 964 ++ base/modules/serial/psb_s_base_mat_mod.f90 | 2105 ++++- base/modules/serial/psb_s_base_vect_mod.f90 | 84 +- base/modules/serial/psb_s_csc_mat_mod.f90 | 628 +- base/modules/serial/psb_s_csr_mat_mod.f90 | 680 +- base/modules/serial/psb_s_mat_mod.F90 | 2740 ++++++ base/modules/serial/psb_s_mat_mod.f90 | 1296 --- base/modules/serial/psb_s_serial_mod.f90 | 91 +- base/modules/serial/psb_s_vect_mod.F90 | 39 +- base/modules/serial/psb_serial_mod.f90 | 17 +- base/modules/serial/psb_vect_mod.f90 | 6 +- base/modules/serial/psb_z_base_mat_mod.f90 | 2105 ++++- base/modules/serial/psb_z_base_vect_mod.f90 | 84 +- base/modules/serial/psb_z_csc_mat_mod.f90 | 628 +- base/modules/serial/psb_z_csr_mat_mod.f90 | 680 +- base/modules/serial/psb_z_mat_mod.F90 | 2740 ++++++ base/modules/serial/psb_z_mat_mod.f90 | 1296 --- base/modules/serial/psb_z_serial_mod.f90 | 91 +- base/modules/serial/psb_z_vect_mod.F90 | 39 +- base/modules/tools/psb_c_tools_a_mod.f90 | 119 + base/modules/tools/psb_c_tools_mod.f90 | 109 +- base/modules/tools/psb_cd_tools_mod.f90 | 203 +- base/modules/tools/psb_d_tools_a_mod.f90 | 119 + base/modules/tools/psb_d_tools_mod.f90 | 109 +- base/modules/tools/psb_e_tools_a_mod.f90 | 119 + base/modules/tools/psb_i_tools_mod.f90 | 265 +- base/modules/tools/psb_l_tools_mod.f90 | 174 + base/modules/tools/psb_m_tools_a_mod.f90 | 119 + base/modules/tools/psb_s_tools_a_mod.f90 | 119 + base/modules/tools/psb_s_tools_mod.f90 | 109 +- base/modules/tools/psb_tools_mod.f90 | 7 + base/modules/tools/psb_z_tools_a_mod.f90 | 119 + base/modules/tools/psb_z_tools_mod.f90 | 109 +- base/psblas/psb_camax.f90 | 45 +- base/psblas/psb_casum.f90 | 36 +- base/psblas/psb_caxpby.f90 | 31 +- base/psblas/psb_cdot.f90 | 67 +- base/psblas/psb_cnrm2.f90 | 48 +- base/psblas/psb_cnrmi.f90 | 7 +- base/psblas/psb_cspmm.f90 | 73 +- base/psblas/psb_cspnrm1.f90 | 3 +- base/psblas/psb_cspsm.f90 | 46 +- base/psblas/psb_damax.f90 | 45 +- base/psblas/psb_dasum.f90 | 36 +- base/psblas/psb_daxpby.f90 | 31 +- base/psblas/psb_ddot.f90 | 67 +- base/psblas/psb_dnrm2.f90 | 48 +- base/psblas/psb_dnrmi.f90 | 7 +- base/psblas/psb_dspmm.f90 | 73 +- base/psblas/psb_dspnrm1.f90 | 3 +- base/psblas/psb_dspsm.f90 | 46 +- base/psblas/psb_samax.f90 | 45 +- base/psblas/psb_sasum.f90 | 36 +- base/psblas/psb_saxpby.f90 | 31 +- base/psblas/psb_sdot.f90 | 67 +- base/psblas/psb_snrm2.f90 | 48 +- base/psblas/psb_snrmi.f90 | 7 +- base/psblas/psb_sspmm.f90 | 73 +- base/psblas/psb_sspnrm1.f90 | 3 +- base/psblas/psb_sspsm.f90 | 46 +- base/psblas/psb_zamax.f90 | 45 +- base/psblas/psb_zasum.f90 | 36 +- base/psblas/psb_zaxpby.f90 | 31 +- base/psblas/psb_zdot.f90 | 67 +- base/psblas/psb_znrm2.f90 | 48 +- base/psblas/psb_znrmi.f90 | 7 +- base/psblas/psb_zspmm.f90 | 73 +- base/psblas/psb_zspnrm1.f90 | 3 +- base/psblas/psb_zspsm.f90 | 46 +- base/serial/Makefile | 4 +- base/serial/impl/Makefile | 13 +- base/serial/impl/psb_base_mat_impl.f90 | 296 + base/serial/impl/psb_c_base_mat_impl.F90 | 2201 ++++- base/serial/impl/psb_c_coo_impl.f90 | 3312 ++++++- base/serial/impl/psb_c_csc_impl.f90 | 1906 +++- base/serial/impl/psb_c_csr_impl.f90 | 2225 ++++- base/serial/impl/psb_c_mat_impl.F90 | 2420 ++++- base/serial/impl/psb_d_base_mat_impl.F90 | 2201 ++++- base/serial/impl/psb_d_coo_impl.f90 | 3312 ++++++- base/serial/impl/psb_d_csc_impl.f90 | 1906 +++- base/serial/impl/psb_d_csr_impl.f90 | 2223 ++++- base/serial/impl/psb_d_mat_impl.F90 | 2420 ++++- base/serial/impl/psb_s_base_mat_impl.F90 | 2201 ++++- base/serial/impl/psb_s_coo_impl.f90 | 3312 ++++++- base/serial/impl/psb_s_csc_impl.f90 | 1906 +++- base/serial/impl/psb_s_csr_impl.f90 | 2225 ++++- base/serial/impl/psb_s_mat_impl.F90 | 2420 ++++- base/serial/impl/psb_z_base_mat_impl.F90 | 2201 ++++- base/serial/impl/psb_z_coo_impl.f90 | 3312 ++++++- base/serial/impl/psb_z_csc_impl.f90 | 1906 +++- base/serial/impl/psb_z_csr_impl.f90 | 2223 ++++- base/serial/impl/psb_z_mat_impl.F90 | 2420 ++++- base/serial/lsmmp.f90 | 478 + base/serial/psb_cnumbmm.f90 | 198 +- base/serial/psb_crwextd.f90 | 237 +- base/serial/psb_cspspmm.f90 | 81 + base/serial/psb_csymbmm.f90 | 220 + base/serial/psb_dnumbmm.f90 | 198 +- base/serial/psb_drwextd.f90 | 241 +- base/serial/psb_dspspmm.f90 | 81 + base/serial/psb_dsymbmm.f90 | 220 + base/serial/psb_snumbmm.f90 | 198 +- base/serial/psb_srwextd.f90 | 237 +- base/serial/psb_sspspmm.f90 | 81 + base/serial/psb_ssymbmm.f90 | 220 + base/serial/psb_znumbmm.f90 | 198 +- base/serial/psb_zrwextd.f90 | 237 +- base/serial/psb_zspspmm.f90 | 81 + base/serial/psb_zsymbmm.f90 | 220 + base/serial/psi_c_serial_impl.f90 | 8 +- base/serial/psi_d_serial_impl.f90 | 8 +- ..._serial_impl.f90 => psi_e_serial_impl.f90} | 174 +- base/serial/psi_m_serial_impl.f90 | 601 ++ base/serial/psi_s_serial_impl.f90 | 8 +- base/serial/psi_z_serial_impl.f90 | 8 +- base/serial/sort/Makefile | 7 +- base/serial/sort/psb_c_hsort_impl.f90 | 16 +- base/serial/sort/psb_c_isort_impl.f90 | 29 +- base/serial/sort/psb_c_msort_impl.f90 | 4 +- base/serial/sort/psb_c_qsort_impl.f90 | 54 +- base/serial/sort/psb_d_hsort_impl.f90 | 16 +- base/serial/sort/psb_d_isort_impl.f90 | 21 +- base/serial/sort/psb_d_msort_impl.f90 | 8 +- base/serial/sort/psb_d_qsort_impl.f90 | 40 +- base/serial/sort/psb_e_hsort_impl.f90 | 678 ++ base/serial/sort/psb_e_isort_impl.f90 | 341 + base/serial/sort/psb_e_msort_impl.f90 | 713 ++ base/serial/sort/psb_e_qsort_impl.f90 | 1318 +++ base/serial/sort/psb_i_hsort_impl.f90 | 16 +- base/serial/sort/psb_i_isort_impl.f90 | 21 +- base/serial/sort/psb_i_msort_impl.f90 | 20 +- base/serial/sort/psb_i_qsort_impl.f90 | 40 +- base/serial/sort/psb_l_hsort_impl.f90 | 678 ++ base/serial/sort/psb_l_isort_impl.f90 | 341 + base/serial/sort/psb_l_msort_impl.f90 | 713 ++ base/serial/sort/psb_l_qsort_impl.f90 | 1318 +++ base/serial/sort/psb_m_hsort_impl.f90 | 678 ++ base/serial/sort/psb_m_isort_impl.f90 | 341 + base/serial/sort/psb_m_msort_impl.f90 | 713 ++ base/serial/sort/psb_m_qsort_impl.f90 | 1318 +++ base/serial/sort/psb_s_hsort_impl.f90 | 16 +- base/serial/sort/psb_s_isort_impl.f90 | 21 +- base/serial/sort/psb_s_msort_impl.f90 | 8 +- base/serial/sort/psb_s_qsort_impl.f90 | 40 +- base/serial/sort/psb_z_hsort_impl.f90 | 16 +- base/serial/sort/psb_z_isort_impl.f90 | 29 +- base/serial/sort/psb_z_msort_impl.f90 | 4 +- base/serial/sort/psb_z_qsort_impl.f90 | 54 +- base/tools/Makefile | 22 +- base/tools/psb_c_map.f90 | 2 +- base/tools/psb_callc.f90 | 230 +- base/tools/psb_callc_a.f90 | 246 + base/tools/psb_casb.f90 | 221 +- base/tools/psb_casb_a.f90 | 259 + base/tools/psb_ccdbldext.F90 | 56 +- base/tools/psb_cd_inloc.f90 | 177 +- base/tools/psb_cd_lstext.f90 | 2 +- base/tools/psb_cd_switch_ovl_indxmap.f90 | 7 +- base/tools/psb_cdall.f90 | 30 +- base/tools/psb_cdals.f90 | 95 +- base/tools/psb_cdalv.f90 | 47 +- base/tools/psb_cdins.f90 | 9 +- base/tools/psb_cdprt.f90 | 2 +- base/tools/psb_cdren.f90 | 8 +- base/tools/psb_cdrep.f90 | 46 +- base/tools/psb_cfree.f90 | 123 - base/tools/psb_cfree_a.f90 | 164 + base/tools/psb_cins.f90 | 399 +- base/tools/psb_cins_a.f90 | 367 + base/tools/psb_cspalloc.f90 | 30 +- base/tools/psb_cspasb.f90 | 7 +- base/tools/psb_cspfree.f90 | 4 +- base/tools/psb_csphalo.F90 | 459 +- base/tools/psb_cspins.f90 | 111 +- base/tools/psb_csprn.f90 | 5 +- base/tools/psb_d_map.f90 | 2 +- base/tools/psb_dallc.f90 | 230 +- base/tools/psb_dallc_a.f90 | 246 + base/tools/psb_dasb.f90 | 221 +- base/tools/psb_dasb_a.f90 | 259 + base/tools/psb_dcdbldext.F90 | 56 +- base/tools/psb_dfree.f90 | 123 - base/tools/psb_dfree_a.f90 | 164 + base/tools/psb_dins.f90 | 399 +- base/tools/psb_dins_a.f90 | 367 + base/tools/psb_dspalloc.f90 | 30 +- base/tools/psb_dspasb.f90 | 7 +- base/tools/psb_dspfree.f90 | 4 +- base/tools/psb_dsphalo.F90 | 459 +- base/tools/psb_dspins.f90 | 111 +- base/tools/psb_dsprn.f90 | 5 +- base/tools/psb_eallc_a.f90 | 246 + base/tools/psb_easb_a.f90 | 259 + base/tools/psb_efree_a.f90 | 164 + base/tools/psb_eins_a.f90 | 367 + base/tools/psb_glob_to_loc.f90 | 13 +- base/tools/psb_iallc.f90 | 230 +- base/tools/psb_iasb.f90 | 221 +- base/tools/psb_icdasb.F90 | 2 +- base/tools/psb_ifree.f90 | 123 - base/tools/psb_iins.f90 | 399 +- base/tools/psb_lallc.f90 | 308 + base/tools/psb_lasb.f90 | 285 + base/tools/psb_lfree.f90 | 199 + base/tools/psb_lins.f90 | 490 + base/tools/psb_loc_to_glob.f90 | 13 +- base/tools/psb_mallc_a.f90 | 246 + base/tools/psb_masb_a.f90 | 259 + base/tools/psb_mfree_a.f90 | 164 + base/tools/psb_mins_a.f90 | 367 + base/tools/psb_s_map.f90 | 2 +- base/tools/psb_sallc.f90 | 230 +- base/tools/psb_sallc_a.f90 | 246 + base/tools/psb_sasb.f90 | 221 +- base/tools/psb_sasb_a.f90 | 259 + base/tools/psb_scdbldext.F90 | 56 +- base/tools/psb_sfree.f90 | 123 - base/tools/psb_sfree_a.f90 | 164 + base/tools/psb_sins.f90 | 399 +- base/tools/psb_sins_a.f90 | 367 + base/tools/psb_sspalloc.f90 | 30 +- base/tools/psb_sspasb.f90 | 7 +- base/tools/psb_sspfree.f90 | 4 +- base/tools/psb_ssphalo.F90 | 459 +- base/tools/psb_sspins.f90 | 111 +- base/tools/psb_ssprn.f90 | 5 +- base/tools/psb_z_map.f90 | 2 +- base/tools/psb_zallc.f90 | 230 +- base/tools/psb_zallc_a.f90 | 246 + base/tools/psb_zasb.f90 | 221 +- base/tools/psb_zasb_a.f90 | 259 + base/tools/psb_zcdbldext.F90 | 56 +- base/tools/psb_zfree.f90 | 123 - base/tools/psb_zfree_a.f90 | 164 + base/tools/psb_zins.f90 | 399 +- base/tools/psb_zins_a.f90 | 367 + base/tools/psb_zspalloc.f90 | 30 +- base/tools/psb_zspasb.f90 | 7 +- base/tools/psb_zspfree.f90 | 4 +- base/tools/psb_zsphalo.F90 | 459 +- base/tools/psb_zspins.f90 | 111 +- base/tools/psb_zsprn.f90 | 5 +- cbind/Makefile | 1 - cbind/base/psb_base_tools_cbind_mod.F90 | 67 +- cbind/base/psb_c_base.h | 31 +- cbind/base/psb_c_cbase.h | 10 +- cbind/base/psb_c_ccomm.c | 2 +- cbind/base/psb_c_ccomm.h | 2 +- cbind/base/psb_c_comm_cbind_mod.f90 | 34 +- cbind/base/psb_c_dbase.h | 10 +- cbind/base/psb_c_dcomm.c | 2 +- cbind/base/psb_c_dcomm.h | 2 +- cbind/base/psb_c_psblas_cbind_mod.f90 | 56 +- cbind/base/psb_c_sbase.h | 10 +- cbind/base/psb_c_scomm.c | 2 +- cbind/base/psb_c_scomm.h | 2 +- cbind/base/psb_c_serial_cbind_mod.F90 | 24 +- cbind/base/psb_c_tools_cbind_mod.F90 | 64 +- cbind/base/psb_c_zbase.h | 10 +- cbind/base/psb_c_zcomm.c | 2 +- cbind/base/psb_c_zcomm.h | 2 +- cbind/base/psb_cpenv_mod.f90 | 89 +- cbind/base/psb_d_comm_cbind_mod.f90 | 34 +- cbind/base/psb_d_psblas_cbind_mod.f90 | 56 +- cbind/base/psb_d_serial_cbind_mod.F90 | 28 +- cbind/base/psb_d_tools_cbind_mod.F90 | 64 +- cbind/base/psb_objhandle_mod.F90 | 9 +- cbind/base/psb_s_comm_cbind_mod.f90 | 34 +- cbind/base/psb_s_psblas_cbind_mod.f90 | 56 +- cbind/base/psb_s_serial_cbind_mod.F90 | 24 +- cbind/base/psb_s_tools_cbind_mod.F90 | 64 +- cbind/base/psb_z_comm_cbind_mod.f90 | 34 +- cbind/base/psb_z_psblas_cbind_mod.f90 | 56 +- cbind/base/psb_z_serial_cbind_mod.F90 | 24 +- cbind/base/psb_z_tools_cbind_mod.F90 | 64 +- cbind/krylov/psb_base_krylov_cbind_mod.f90 | 6 +- cbind/krylov/psb_ckrylov_cbind_mod.f90 | 18 +- cbind/krylov/psb_dkrylov_cbind_mod.f90 | 18 +- cbind/krylov/psb_skrylov_cbind_mod.f90 | 18 +- cbind/krylov/psb_zkrylov_cbind_mod.f90 | 18 +- cbind/prec/psb_cprec_cbind_mod.f90 | 18 +- cbind/prec/psb_dprec_cbind_mod.f90 | 18 +- cbind/prec/psb_sprec_cbind_mod.f90 | 18 +- cbind/prec/psb_zprec_cbind_mod.f90 | 18 +- cbind/test/pargen/Makefile | 6 +- cbind/test/pargen/ppdec.c | 200 +- cbind/test/pargen/runs/ppde.inp | 2 +- config/pac.m4 | 59 + configure | 8407 ++++++----------- configure.ac | 27 +- docs/html/footnode.html | 2 +- docs/html/img1.png | Bin 200 -> 191 bytes docs/html/img10.png | Bin 404 -> 358 bytes docs/html/img100.png | Bin 178 -> 174 bytes docs/html/img101.png | Bin 363 -> 335 bytes docs/html/img102.png | Bin 533 -> 486 bytes docs/html/img103.png | Bin 359 -> 309 bytes docs/html/img104.png | Bin 368 -> 339 bytes docs/html/img105.png | Bin 228 -> 218 bytes docs/html/img106.png | Bin 340 -> 309 bytes docs/html/img107.png | Bin 259 -> 257 bytes docs/html/img108.png | Bin 194 -> 184 bytes docs/html/img109.png | Bin 737 -> 624 bytes docs/html/img11.png | Bin 526 -> 476 bytes docs/html/img110.png | Bin 373 -> 334 bytes docs/html/img111.png | Bin 134 -> 137 bytes docs/html/img112.png | Bin 257 -> 253 bytes docs/html/img113.png | Bin 390 -> 348 bytes docs/html/img114.png | Bin 263 -> 235 bytes docs/html/img115.png | Bin 244 -> 223 bytes docs/html/img116.png | Bin 276 -> 222 bytes docs/html/img117.png | Bin 374 -> 368 bytes docs/html/img118.png | Bin 222 -> 203 bytes docs/html/img119.png | Bin 259 -> 237 bytes docs/html/img12.png | Bin 129 -> 123 bytes docs/html/img120.png | Bin 808 -> 762 bytes docs/html/img121.png | Bin 412 -> 366 bytes docs/html/img122.png | Bin 431 -> 384 bytes docs/html/img123.png | Bin 354 -> 320 bytes docs/html/img124.png | Bin 310 -> 295 bytes docs/html/img125.png | Bin 839 -> 775 bytes docs/html/img126.png | Bin 335 -> 298 bytes docs/html/img127.png | Bin 500 -> 489 bytes docs/html/img128.png | Bin 402 -> 381 bytes docs/html/img129.png | Bin 267 -> 232 bytes docs/html/img13.png | Bin 3167 -> 2914 bytes docs/html/img130.png | Bin 533 -> 497 bytes docs/html/img131.png | Bin 545 -> 530 bytes docs/html/img132.png | Bin 335 -> 322 bytes docs/html/img133.png | Bin 232 -> 229 bytes docs/html/img134.png | Bin 520 -> 481 bytes docs/html/img135.png | Bin 613 -> 507 bytes docs/html/img136.png | Bin 581 -> 457 bytes docs/html/img138.png | Bin 277 -> 244 bytes docs/html/img139.png | Bin 870 -> 794 bytes docs/html/img14.png | Bin 643 -> 582 bytes docs/html/img140.png | Bin 215 -> 207 bytes docs/html/img141.png | Bin 583 -> 522 bytes docs/html/img142.png | Bin 732 -> 664 bytes docs/html/img143.png | Bin 523 -> 494 bytes docs/html/img144.png | Bin 268 -> 257 bytes docs/html/img145.png | Bin 572 -> 481 bytes docs/html/img146.png | Bin 240 -> 233 bytes docs/html/img148.png | Bin 8603 -> 8250 bytes docs/html/img15.png | Bin 230 -> 223 bytes docs/html/img150.png | Bin 1099 -> 975 bytes docs/html/img151.png | Bin 758 -> 707 bytes docs/html/img152.png | Bin 875 -> 805 bytes docs/html/img153.png | Bin 867 -> 845 bytes docs/html/img154.png | Bin 1172 -> 1040 bytes docs/html/img155.png | Bin 1348 -> 1215 bytes docs/html/img156.png | Bin 1029 -> 927 bytes docs/html/img157.png | Bin 1121 -> 998 bytes docs/html/img158.png | Bin 1209 -> 1043 bytes docs/html/img159.png | Bin 1156 -> 1012 bytes docs/html/img16.png | Bin 196 -> 187 bytes docs/html/img160.png | Bin 373 -> 320 bytes docs/html/img161.png | Bin 431 -> 398 bytes docs/html/img162.png | Bin 304 -> 254 bytes docs/html/img163.png | Bin 915 -> 797 bytes docs/html/img164.png | Bin 678 -> 601 bytes docs/html/img165.png | Bin 659 -> 589 bytes docs/html/img166.png | Bin 219 -> 206 bytes docs/html/img167.png | Bin 429 -> 376 bytes docs/html/img168.png | Bin 2452 -> 2020 bytes docs/html/img17.png | Bin 371 -> 347 bytes docs/html/img18.png | Bin 540 -> 481 bytes docs/html/img19.png | Bin 486 -> 460 bytes docs/html/img2.png | Bin 3108 -> 2456 bytes docs/html/img20.png | Bin 184 -> 178 bytes docs/html/img21.png | Bin 231 -> 197 bytes docs/html/img22.png | Bin 201 -> 185 bytes docs/html/img23.png | Bin 225 -> 201 bytes docs/html/img24.png | Bin 469 -> 417 bytes docs/html/img25.png | Bin 482 -> 436 bytes docs/html/img26.png | Bin 267 -> 258 bytes docs/html/img27.png | Bin 4180 -> 2500 bytes docs/html/img28.png | Bin 791 -> 667 bytes docs/html/img29.png | Bin 245 -> 238 bytes docs/html/img3.png | Bin 3149 -> 2442 bytes docs/html/img30.png | Bin 591 -> 531 bytes docs/html/img31.png | Bin 1090 -> 894 bytes docs/html/img32.png | Bin 311 -> 292 bytes docs/html/img33.png | Bin 3994 -> 2262 bytes docs/html/img34.png | Bin 799 -> 713 bytes docs/html/img35.png | Bin 454 -> 432 bytes docs/html/img36.png | Bin 875 -> 731 bytes docs/html/img37.png | Bin 311 -> 308 bytes docs/html/img38.png | Bin 3960 -> 2224 bytes docs/html/img39.png | Bin 508 -> 462 bytes docs/html/img4.png | Bin 178 -> 167 bytes docs/html/img40.png | Bin 909 -> 730 bytes docs/html/img41.png | Bin 564 -> 523 bytes docs/html/img42.png | Bin 572 -> 536 bytes docs/html/img43.png | Bin 320 -> 318 bytes docs/html/img44.png | Bin 4024 -> 2266 bytes docs/html/img45.png | Bin 655 -> 576 bytes docs/html/img46.png | Bin 476 -> 403 bytes docs/html/img47.png | Bin 498 -> 438 bytes docs/html/img48.png | Bin 536 -> 483 bytes docs/html/img49.png | Bin 572 -> 549 bytes docs/html/img5.png | Bin 200 -> 191 bytes docs/html/img50.png | Bin 597 -> 528 bytes docs/html/img51.png | Bin 243 -> 216 bytes docs/html/img52.png | Bin 256 -> 231 bytes docs/html/img53.png | Bin 415 -> 389 bytes docs/html/img54.png | Bin 2923 -> 1721 bytes docs/html/img55.png | Bin 192 -> 198 bytes docs/html/img56.png | Bin 229 -> 215 bytes docs/html/img57.png | Bin 421 -> 412 bytes docs/html/img58.png | Bin 824 -> 705 bytes docs/html/img59.png | Bin 283 -> 222 bytes docs/html/img6.png | Bin 376 -> 328 bytes docs/html/img60.png | Bin 1916 -> 1290 bytes docs/html/img61.png | Bin 3748 -> 2378 bytes docs/html/img62.png | Bin 3122 -> 2279 bytes docs/html/img63.png | Bin 367 -> 310 bytes docs/html/img64.png | Bin 253 -> 229 bytes docs/html/img65.png | Bin 247 -> 223 bytes docs/html/img66.png | Bin 261 -> 235 bytes docs/html/img67.png | Bin 2398 -> 1642 bytes docs/html/img68.png | Bin 261 -> 235 bytes docs/html/img69.png | Bin 335 -> 280 bytes docs/html/img7.png | Bin 202 -> 190 bytes docs/html/img70.png | Bin 773 -> 685 bytes docs/html/img71.png | Bin 5090 -> 4708 bytes docs/html/img72.png | Bin 5450 -> 4860 bytes docs/html/img73.png | Bin 805 -> 703 bytes docs/html/img74.png | Bin 368 -> 350 bytes docs/html/img75.png | Bin 502 -> 472 bytes docs/html/img76.png | Bin 326 -> 307 bytes docs/html/img77.png | Bin 366 -> 330 bytes docs/html/img78.png | Bin 301 -> 277 bytes docs/html/img79.png | Bin 2461 -> 1267 bytes docs/html/img8.png | Bin 231 -> 222 bytes docs/html/img80.png | Bin 373 -> 275 bytes docs/html/img81.png | Bin 539 -> 429 bytes docs/html/img82.png | Bin 167 -> 152 bytes docs/html/img83.png | Bin 800 -> 724 bytes docs/html/img84.png | Bin 369 -> 341 bytes docs/html/img85.png | Bin 1401 -> 1312 bytes docs/html/img86.png | Bin 502 -> 430 bytes docs/html/img87.png | Bin 366 -> 333 bytes docs/html/img88.png | Bin 256 -> 233 bytes docs/html/img89.png | Bin 243 -> 221 bytes docs/html/img9.png | Bin 242 -> 230 bytes docs/html/img90.png | Bin 186 -> 180 bytes docs/html/img91.png | Bin 418 -> 396 bytes docs/html/img92.png | Bin 507 -> 479 bytes docs/html/img93.png | Bin 219 -> 211 bytes docs/html/img94.png | Bin 582 -> 540 bytes docs/html/img95.png | Bin 319 -> 275 bytes docs/html/img96.png | Bin 457 -> 408 bytes docs/html/img97.png | Bin 394 -> 345 bytes docs/html/img98.png | Bin 285 -> 259 bytes docs/html/img99.png | Bin 415 -> 373 bytes docs/html/node100.html | 4 +- docs/html/node101.html | 6 +- docs/html/node102.html | 2 +- docs/html/node104.html | 4 +- docs/html/node108.html | 2 +- docs/html/node109.html | 4 +- docs/html/node110.html | 4 +- docs/html/node111.html | 4 +- docs/html/node112.html | 4 +- docs/html/node113.html | 4 +- docs/html/node114.html | 12 +- docs/html/node115.html | 12 +- docs/html/node116.html | 12 +- docs/html/node117.html | 4 +- docs/html/node119.html | 2 +- docs/html/node12.html | 2 +- docs/html/node120.html | 2 +- docs/html/node121.html | 2 +- docs/html/node122.html | 2 +- docs/html/node123.html | 2 +- docs/html/node124.html | 2 +- docs/html/node126.html | 8 +- docs/html/node129.html | 4 +- docs/html/node13.html | 2 +- docs/html/node133.html | 26 +- docs/html/node134.html | 180 + docs/html/node135.html | 67 + docs/html/node3.html | 2 +- docs/html/node4.html | 24 +- docs/html/node48.html | 6 +- docs/html/node53.html | 26 +- docs/html/node54.html | 38 +- docs/html/node55.html | 36 +- docs/html/node56.html | 20 +- docs/html/node57.html | 12 +- docs/html/node58.html | 20 +- docs/html/node59.html | 22 +- docs/html/node6.html | 26 +- docs/html/node60.html | 20 +- docs/html/node61.html | 12 +- docs/html/node62.html | 14 +- docs/html/node63.html | 14 +- docs/html/node64.html | 50 +- docs/html/node65.html | 54 +- docs/html/node67.html | 22 +- docs/html/node68.html | 30 +- docs/html/node69.html | 20 +- docs/html/node7.html | 4 +- docs/html/node70.html | 18 +- docs/html/node72.html | 36 +- docs/html/node73.html | 18 +- docs/html/node77.html | 2 +- docs/html/node78.html | 2 +- docs/html/node79.html | 14 +- docs/html/node83.html | 4 +- docs/html/node84.html | 8 +- docs/html/node85.html | 2 +- docs/html/node87.html | 8 +- docs/html/node88.html | 10 +- docs/html/node89.html | 10 +- docs/html/node9.html | 24 +- docs/html/node90.html | 2 +- docs/html/node91.html | 2 +- docs/html/node92.html | 2 +- docs/html/node93.html | 2 +- docs/html/node96.html | 12 +- docs/html/node97.html | 2 +- docs/html/node98.html | 34 +- docs/psblas-3.6.pdf | 3896 ++++---- docs/src/datastruct.tex | 16 +- docs/src/intro.tex | 4 +- krylov/psb_c_krylov_conv_mod.f90 | 10 +- krylov/psb_cbicg.f90 | 11 +- krylov/psb_ccg.F90 | 11 +- krylov/psb_ccgs.f90 | 7 +- krylov/psb_ccgstab.f90 | 7 +- krylov/psb_ccgstabl.f90 | 12 +- krylov/psb_cfcg.F90 | 7 +- krylov/psb_cgcr.f90 | 14 +- krylov/psb_crgmres.f90 | 15 +- krylov/psb_d_krylov_conv_mod.f90 | 10 +- krylov/psb_dbicg.f90 | 11 +- krylov/psb_dcg.F90 | 13 +- krylov/psb_dcgs.f90 | 7 +- krylov/psb_dcgstab.f90 | 7 +- krylov/psb_dcgstabl.f90 | 12 +- krylov/psb_dfcg.F90 | 7 +- krylov/psb_dgcr.f90 | 14 +- krylov/psb_drgmres.f90 | 15 +- krylov/psb_s_krylov_conv_mod.f90 | 10 +- krylov/psb_sbicg.f90 | 11 +- krylov/psb_scg.F90 | 13 +- krylov/psb_scgs.f90 | 7 +- krylov/psb_scgstab.f90 | 7 +- krylov/psb_scgstabl.f90 | 12 +- krylov/psb_sfcg.F90 | 7 +- krylov/psb_sgcr.f90 | 14 +- krylov/psb_srgmres.f90 | 15 +- krylov/psb_z_krylov_conv_mod.f90 | 10 +- krylov/psb_zbicg.f90 | 11 +- krylov/psb_zcg.F90 | 11 +- krylov/psb_zcgs.f90 | 7 +- krylov/psb_zcgstab.f90 | 7 +- krylov/psb_zcgstabl.f90 | 12 +- krylov/psb_zfcg.F90 | 7 +- krylov/psb_zgcr.f90 | 14 +- krylov/psb_zrgmres.f90 | 15 +- notes.txt | 32 + prec/impl/psb_c_bjacprec_impl.f90 | 4 +- prec/impl/psb_cprecbld.f90 | 9 +- prec/impl/psb_d_bjacprec_impl.f90 | 4 +- prec/impl/psb_dprecbld.f90 | 9 +- prec/impl/psb_s_bjacprec_impl.f90 | 4 +- prec/impl/psb_sprecbld.f90 | 9 +- prec/impl/psb_z_bjacprec_impl.f90 | 4 +- prec/impl/psb_zprecbld.f90 | 9 +- prec/psb_c_base_prec_mod.f90 | 10 +- prec/psb_c_bjacprec.f90 | 4 +- prec/psb_c_diagprec.f90 | 4 +- prec/psb_c_nullprec.f90 | 2 +- prec/psb_c_prec_type.f90 | 14 +- prec/psb_d_base_prec_mod.f90 | 10 +- prec/psb_d_bjacprec.f90 | 4 +- prec/psb_d_diagprec.f90 | 4 +- prec/psb_d_nullprec.f90 | 2 +- prec/psb_d_prec_type.f90 | 14 +- prec/psb_prec_const_mod.f90 | 2 +- prec/psb_s_base_prec_mod.f90 | 10 +- prec/psb_s_bjacprec.f90 | 4 +- prec/psb_s_diagprec.f90 | 4 +- prec/psb_s_nullprec.f90 | 2 +- prec/psb_s_prec_type.f90 | 14 +- prec/psb_z_base_prec_mod.f90 | 10 +- prec/psb_z_bjacprec.f90 | 4 +- prec/psb_z_diagprec.f90 | 4 +- prec/psb_z_nullprec.f90 | 2 +- prec/psb_z_prec_type.f90 | 14 +- test/fileread/psb_cf_sample.f90 | 4 +- test/fileread/psb_df_sample.f90 | 4 +- test/fileread/psb_sf_sample.f90 | 4 +- test/fileread/psb_zf_sample.f90 | 4 +- test/hello/Makefile | 6 +- test/idx/Makefile | 43 + test/idx/psb_d_pde3d.f90 | 843 ++ test/idx/tryidxijk.f90 | 20 + test/kernel/d_file_spmv.f90 | 6 +- test/kernel/pdgenspmv.f90 | 6 +- test/kernel/s_file_spmv.f90 | 6 +- test/pargen/psb_d_pde2d.f90 | 55 +- test/pargen/psb_d_pde3d.f90 | 57 +- test/pargen/psb_s_pde2d.f90 | 55 +- test/pargen/psb_s_pde3d.f90 | 57 +- test/pargen/runs/ppde.inp | 5 +- test/serial/d_matgen.F90 | 2 +- test/serial/psb_d_xyz_mat_mod.f90 | 8 +- util/psb_blockpart_mod.f90 | 15 +- util/psb_c_hbio_impl.f90 | 335 + util/psb_c_mat_dist_impl.f90 | 327 +- util/psb_c_mat_dist_mod.f90 | 61 +- util/psb_c_mmio_impl.f90 | 176 + util/psb_c_renum_impl.F90 | 2 +- util/psb_d_hbio_impl.f90 | 287 + util/psb_d_mat_dist_impl.f90 | 327 +- util/psb_d_mat_dist_mod.f90 | 61 +- util/psb_d_mmio_impl.f90 | 177 + util/psb_d_renum_impl.F90 | 2 +- util/psb_hbio_mod.f90 | 89 +- util/psb_metispart_mod.F90 | 14 +- util/psb_mmio_mod.F90 | 72 +- util/psb_partidx_mod.F90 | 389 +- util/psb_s_hbio_impl.f90 | 287 + util/psb_s_mat_dist_impl.f90 | 327 +- util/psb_s_mat_dist_mod.f90 | 61 +- util/psb_s_mmio_impl.f90 | 153 + util/psb_s_renum_impl.F90 | 2 +- util/psb_z_hbio_impl.f90 | 332 +- util/psb_z_mat_dist_impl.f90 | 327 +- util/psb_z_mat_dist_mod.f90 | 61 +- util/psb_z_mmio_impl.f90 | 175 + util/psb_z_renum_impl.F90 | 2 +- 921 files changed, 172036 insertions(+), 57462 deletions(-) create mode 100644 base/comm/internals/psi_covrl_restr_a.f90 create mode 100644 base/comm/internals/psi_covrl_save_a.f90 create mode 100644 base/comm/internals/psi_covrl_upd_a.f90 create mode 100644 base/comm/internals/psi_cswapdata_a.F90 create mode 100644 base/comm/internals/psi_cswaptran_a.F90 create mode 100644 base/comm/internals/psi_dovrl_restr_a.f90 create mode 100644 base/comm/internals/psi_dovrl_save_a.f90 create mode 100644 base/comm/internals/psi_dovrl_upd_a.f90 create mode 100644 base/comm/internals/psi_dswapdata_a.F90 create mode 100644 base/comm/internals/psi_dswaptran_a.F90 create mode 100644 base/comm/internals/psi_eovrl_restr_a.f90 create mode 100644 base/comm/internals/psi_eovrl_save_a.f90 create mode 100644 base/comm/internals/psi_eovrl_upd_a.f90 create mode 100644 base/comm/internals/psi_eswapdata_a.F90 create mode 100644 base/comm/internals/psi_eswaptran_a.F90 create mode 100644 base/comm/internals/psi_lovrl_restr.f90 create mode 100644 base/comm/internals/psi_lovrl_save.f90 create mode 100644 base/comm/internals/psi_lovrl_upd.f90 create mode 100644 base/comm/internals/psi_lswapdata.F90 create mode 100644 base/comm/internals/psi_lswaptran.F90 create mode 100644 base/comm/internals/psi_movrl_restr_a.f90 create mode 100644 base/comm/internals/psi_movrl_save_a.f90 create mode 100644 base/comm/internals/psi_movrl_upd_a.f90 create mode 100644 base/comm/internals/psi_mswapdata_a.F90 create mode 100644 base/comm/internals/psi_mswaptran_a.F90 create mode 100644 base/comm/internals/psi_sovrl_restr_a.f90 create mode 100644 base/comm/internals/psi_sovrl_save_a.f90 create mode 100644 base/comm/internals/psi_sovrl_upd_a.f90 create mode 100644 base/comm/internals/psi_sswapdata_a.F90 create mode 100644 base/comm/internals/psi_sswaptran_a.F90 create mode 100644 base/comm/internals/psi_zovrl_restr_a.f90 create mode 100644 base/comm/internals/psi_zovrl_save_a.f90 create mode 100644 base/comm/internals/psi_zovrl_upd_a.f90 create mode 100644 base/comm/internals/psi_zswapdata_a.F90 create mode 100644 base/comm/internals/psi_zswaptran_a.F90 create mode 100644 base/comm/psb_cgather_a.f90 create mode 100644 base/comm/psb_chalo_a.f90 create mode 100644 base/comm/psb_covrl_a.f90 create mode 100644 base/comm/psb_cscatter_a.F90 create mode 100644 base/comm/psb_dgather_a.f90 create mode 100644 base/comm/psb_dhalo_a.f90 create mode 100644 base/comm/psb_dovrl_a.f90 create mode 100644 base/comm/psb_dscatter_a.F90 create mode 100644 base/comm/psb_egather_a.f90 create mode 100644 base/comm/psb_ehalo_a.f90 create mode 100644 base/comm/psb_eovrl_a.f90 create mode 100644 base/comm/psb_escatter_a.F90 create mode 100644 base/comm/psb_ispgather.F90 create mode 100644 base/comm/psb_lgather.f90 create mode 100644 base/comm/psb_lhalo.f90 create mode 100644 base/comm/psb_lovrl.f90 create mode 100644 base/comm/psb_lscatter.F90 create mode 100644 base/comm/psb_lspgather.F90 create mode 100644 base/comm/psb_mgather_a.f90 create mode 100644 base/comm/psb_mhalo_a.f90 create mode 100644 base/comm/psb_movrl_a.f90 create mode 100644 base/comm/psb_mscatter_a.F90 create mode 100644 base/comm/psb_sgather_a.f90 create mode 100644 base/comm/psb_shalo_a.f90 create mode 100644 base/comm/psb_sovrl_a.f90 create mode 100644 base/comm/psb_sscatter_a.F90 create mode 100644 base/comm/psb_zgather_a.f90 create mode 100644 base/comm/psb_zhalo_a.f90 create mode 100644 base/comm/psb_zovrl_a.f90 create mode 100644 base/comm/psb_zscatter_a.F90 delete mode 100644 base/modules/aux/psb_ip_reord_mod.f90 create mode 100644 base/modules/auxil/psb_c_hsort_mod.f90 create mode 100644 base/modules/auxil/psb_c_hsort_x_mod.f90 create mode 100644 base/modules/auxil/psb_c_ip_reord_mod.F90 create mode 100644 base/modules/auxil/psb_c_isort_mod.f90 create mode 100644 base/modules/auxil/psb_c_msort_mod.f90 create mode 100644 base/modules/auxil/psb_c_qsort_mod.f90 create mode 100644 base/modules/auxil/psb_c_realloc_mod.F90 rename base/modules/{aux => auxil}/psb_c_sort_mod.f90 (99%) create mode 100644 base/modules/auxil/psb_d_hsort_mod.f90 create mode 100644 base/modules/auxil/psb_d_hsort_x_mod.f90 create mode 100644 base/modules/auxil/psb_d_ip_reord_mod.F90 create mode 100644 base/modules/auxil/psb_d_isort_mod.f90 create mode 100644 base/modules/auxil/psb_d_msort_mod.f90 create mode 100644 base/modules/auxil/psb_d_qsort_mod.f90 create mode 100644 base/modules/auxil/psb_d_realloc_mod.F90 rename base/modules/{aux => auxil}/psb_d_sort_mod.f90 (99%) create mode 100644 base/modules/auxil/psb_e_hsort_mod.f90 create mode 100644 base/modules/auxil/psb_e_ip_reord_mod.F90 create mode 100644 base/modules/auxil/psb_e_isort_mod.f90 create mode 100644 base/modules/auxil/psb_e_msort_mod.f90 create mode 100644 base/modules/auxil/psb_e_qsort_mod.f90 create mode 100644 base/modules/auxil/psb_e_realloc_mod.F90 create mode 100644 base/modules/auxil/psb_i_hsort_x_mod.f90 rename base/modules/{aux => auxil}/psb_i_sort_mod.f90 (98%) rename base/modules/{aux/psb_sort_mod.f90 => auxil/psb_ip_reord_mod.F90} (79%) create mode 100644 base/modules/auxil/psb_l_hsort_x_mod.f90 create mode 100644 base/modules/auxil/psb_l_sort_mod.f90 create mode 100644 base/modules/auxil/psb_m_hsort_mod.f90 create mode 100644 base/modules/auxil/psb_m_ip_reord_mod.F90 create mode 100644 base/modules/auxil/psb_m_isort_mod.f90 create mode 100644 base/modules/auxil/psb_m_msort_mod.f90 create mode 100644 base/modules/auxil/psb_m_qsort_mod.f90 create mode 100644 base/modules/auxil/psb_m_realloc_mod.F90 create mode 100644 base/modules/auxil/psb_s_hsort_mod.f90 create mode 100644 base/modules/auxil/psb_s_hsort_x_mod.f90 create mode 100644 base/modules/auxil/psb_s_ip_reord_mod.F90 create mode 100644 base/modules/auxil/psb_s_isort_mod.f90 create mode 100644 base/modules/auxil/psb_s_msort_mod.f90 create mode 100644 base/modules/auxil/psb_s_qsort_mod.f90 create mode 100644 base/modules/auxil/psb_s_realloc_mod.F90 rename base/modules/{aux => auxil}/psb_s_sort_mod.f90 (99%) create mode 100644 base/modules/auxil/psb_sort_mod.f90 rename base/modules/{aux => auxil}/psb_string_mod.f90 (100%) create mode 100644 base/modules/auxil/psb_z_hsort_mod.f90 create mode 100644 base/modules/auxil/psb_z_hsort_x_mod.f90 create mode 100644 base/modules/auxil/psb_z_ip_reord_mod.F90 create mode 100644 base/modules/auxil/psb_z_isort_mod.f90 create mode 100644 base/modules/auxil/psb_z_msort_mod.f90 create mode 100644 base/modules/auxil/psb_z_qsort_mod.f90 create mode 100644 base/modules/auxil/psb_z_realloc_mod.F90 rename base/modules/{aux => auxil}/psb_z_sort_mod.f90 (99%) rename base/modules/{aux => auxil}/psi_c_serial_mod.f90 (98%) rename base/modules/{aux => auxil}/psi_d_serial_mod.f90 (98%) rename base/modules/{aux/psi_i_serial_mod.f90 => auxil/psi_e_serial_mod.f90} (55%) create mode 100644 base/modules/auxil/psi_m_serial_mod.f90 rename base/modules/{aux => auxil}/psi_s_serial_mod.f90 (98%) rename base/modules/{aux => auxil}/psi_serial_mod.f90 (97%) rename base/modules/{aux => auxil}/psi_z_serial_mod.f90 (98%) create mode 100644 base/modules/comm/psb_c_comm_a_mod.f90 create mode 100644 base/modules/comm/psb_d_comm_a_mod.f90 create mode 100644 base/modules/comm/psb_e_comm_a_mod.f90 create mode 100644 base/modules/comm/psb_l_comm_mod.f90 create mode 100644 base/modules/comm/psb_m_comm_a_mod.f90 create mode 100644 base/modules/comm/psb_s_comm_a_mod.f90 create mode 100644 base/modules/comm/psb_z_comm_a_mod.f90 create mode 100644 base/modules/comm/psi_c_comm_a_mod.f90 rename base/modules/{psi_c_mod.f90 => comm/psi_c_comm_v_mod.f90} (60%) create mode 100644 base/modules/comm/psi_d_comm_a_mod.f90 rename base/modules/{psi_d_mod.f90 => comm/psi_d_comm_v_mod.f90} (61%) create mode 100644 base/modules/comm/psi_e_comm_a_mod.f90 create mode 100644 base/modules/comm/psi_i_comm_v_mod.f90 create mode 100644 base/modules/comm/psi_l_comm_v_mod.f90 create mode 100644 base/modules/comm/psi_m_comm_a_mod.f90 create mode 100644 base/modules/comm/psi_s_comm_a_mod.f90 rename base/modules/{psi_s_mod.f90 => comm/psi_s_comm_v_mod.f90} (61%) create mode 100644 base/modules/comm/psi_z_comm_a_mod.f90 rename base/modules/{psi_z_mod.f90 => comm/psi_z_comm_v_mod.f90} (60%) rename base/modules/{aux/psb_hash_mod.f90 => desc/psb_hash_mod.F90} (62%) create mode 100644 base/modules/desc/psb_hashval.c create mode 100644 base/modules/penv/psi_c_collective_mod.F90 create mode 100644 base/modules/penv/psi_c_p2p_mod.F90 create mode 100644 base/modules/penv/psi_collective_mod.F90 rename base/modules/{ => penv}/psi_comm_buffers_mod.F90 (72%) create mode 100644 base/modules/penv/psi_d_collective_mod.F90 create mode 100644 base/modules/penv/psi_d_p2p_mod.F90 create mode 100644 base/modules/penv/psi_e_collective_mod.F90 create mode 100644 base/modules/penv/psi_e_p2p_mod.F90 create mode 100644 base/modules/penv/psi_m_collective_mod.F90 create mode 100644 base/modules/penv/psi_m_p2p_mod.F90 create mode 100644 base/modules/penv/psi_p2p_mod.F90 rename base/modules/{ => penv}/psi_penv_mod.F90 (72%) create mode 100644 base/modules/penv/psi_s_collective_mod.F90 create mode 100644 base/modules/penv/psi_s_p2p_mod.F90 create mode 100644 base/modules/penv/psi_z_collective_mod.F90 create mode 100644 base/modules/penv/psi_z_p2p_mod.F90 create mode 100644 base/modules/psb_cbind_const_mod.F90 delete mode 100644 base/modules/psi_bcast_mod.F90 create mode 100644 base/modules/psi_c_mod.F90 create mode 100644 base/modules/psi_d_mod.F90 create mode 100644 base/modules/psi_i_mod.F90 delete mode 100644 base/modules/psi_i_mod.f90 create mode 100644 base/modules/psi_l_mod.F90 delete mode 100644 base/modules/psi_p2p_mod.F90 delete mode 100644 base/modules/psi_reduce_mod.F90 create mode 100644 base/modules/psi_s_mod.F90 create mode 100644 base/modules/psi_z_mod.F90 create mode 100644 base/modules/serial/psb_c_mat_mod.F90 delete mode 100644 base/modules/serial/psb_c_mat_mod.f90 create mode 100644 base/modules/serial/psb_d_mat_mod.F90 delete mode 100644 base/modules/serial/psb_d_mat_mod.f90 create mode 100644 base/modules/serial/psb_l_base_vect_mod.f90 create mode 100644 base/modules/serial/psb_l_vect_mod.F90 create mode 100644 base/modules/serial/psb_s_mat_mod.F90 delete mode 100644 base/modules/serial/psb_s_mat_mod.f90 create mode 100644 base/modules/serial/psb_z_mat_mod.F90 delete mode 100644 base/modules/serial/psb_z_mat_mod.f90 create mode 100644 base/modules/tools/psb_c_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_d_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_e_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_l_tools_mod.f90 create mode 100644 base/modules/tools/psb_m_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_s_tools_a_mod.f90 create mode 100644 base/modules/tools/psb_z_tools_a_mod.f90 create mode 100644 base/serial/lsmmp.f90 rename base/serial/{psi_i_serial_impl.f90 => psi_e_serial_impl.f90} (76%) create mode 100644 base/serial/psi_m_serial_impl.f90 create mode 100644 base/serial/sort/psb_e_hsort_impl.f90 create mode 100644 base/serial/sort/psb_e_isort_impl.f90 create mode 100644 base/serial/sort/psb_e_msort_impl.f90 create mode 100644 base/serial/sort/psb_e_qsort_impl.f90 create mode 100644 base/serial/sort/psb_l_hsort_impl.f90 create mode 100644 base/serial/sort/psb_l_isort_impl.f90 create mode 100644 base/serial/sort/psb_l_msort_impl.f90 create mode 100644 base/serial/sort/psb_l_qsort_impl.f90 create mode 100644 base/serial/sort/psb_m_hsort_impl.f90 create mode 100644 base/serial/sort/psb_m_isort_impl.f90 create mode 100644 base/serial/sort/psb_m_msort_impl.f90 create mode 100644 base/serial/sort/psb_m_qsort_impl.f90 create mode 100644 base/tools/psb_callc_a.f90 create mode 100644 base/tools/psb_casb_a.f90 create mode 100644 base/tools/psb_cfree_a.f90 create mode 100644 base/tools/psb_cins_a.f90 create mode 100644 base/tools/psb_dallc_a.f90 create mode 100644 base/tools/psb_dasb_a.f90 create mode 100644 base/tools/psb_dfree_a.f90 create mode 100644 base/tools/psb_dins_a.f90 create mode 100644 base/tools/psb_eallc_a.f90 create mode 100644 base/tools/psb_easb_a.f90 create mode 100644 base/tools/psb_efree_a.f90 create mode 100644 base/tools/psb_eins_a.f90 create mode 100644 base/tools/psb_lallc.f90 create mode 100644 base/tools/psb_lasb.f90 create mode 100644 base/tools/psb_lfree.f90 create mode 100644 base/tools/psb_lins.f90 create mode 100644 base/tools/psb_mallc_a.f90 create mode 100644 base/tools/psb_masb_a.f90 create mode 100644 base/tools/psb_mfree_a.f90 create mode 100644 base/tools/psb_mins_a.f90 create mode 100644 base/tools/psb_sallc_a.f90 create mode 100644 base/tools/psb_sasb_a.f90 create mode 100644 base/tools/psb_sfree_a.f90 create mode 100644 base/tools/psb_sins_a.f90 create mode 100644 base/tools/psb_zallc_a.f90 create mode 100644 base/tools/psb_zasb_a.f90 create mode 100644 base/tools/psb_zfree_a.f90 create mode 100644 base/tools/psb_zins_a.f90 create mode 100644 docs/html/node134.html create mode 100644 docs/html/node135.html create mode 100644 notes.txt create mode 100644 test/idx/Makefile create mode 100644 test/idx/psb_d_pde3d.f90 create mode 100644 test/idx/tryidxijk.f90 diff --git a/Changelog b/Changelog index 046f03147..077e1e6ca 100644 --- a/Changelog +++ b/Changelog @@ -6,6 +6,7 @@ Changelog. A lot less detailed than usual, at least for past 2018/08/10: Optional arguments in GETROW method. 2018/07/30: Improved TRIL/TRIU implementations. 2018/06/14: New FCG code. +2018/04/24: Merged changes to error handling internals. 2018/04/23: Change default for CDALL with VL. New GLOBAL argument for reductions. 2018/04/15: Fixed pargen benchmark programs. Made MOLD mandatory. diff --git a/base/comm/Makefile b/base/comm/Makefile index 63c46043f..f27d38cfc 100644 --- a/base/comm/Makefile +++ b/base/comm/Makefile @@ -3,12 +3,25 @@ include ../../Make.inc OBJS = psb_dgather.o psb_dhalo.o psb_dovrl.o \ psb_sgather.o psb_shalo.o psb_sovrl.o \ psb_igather.o psb_ihalo.o psb_iovrl.o \ + psb_lgather.o psb_lhalo.o psb_lovrl.o \ psb_cgather.o psb_chalo.o psb_covrl.o \ - psb_zgather.o psb_zhalo.o psb_zovrl.o + psb_zgather.o psb_zhalo.o psb_zovrl.o \ + psb_dgather_a.o psb_dhalo_a.o psb_dovrl_a.o \ + psb_sgather_a.o psb_shalo_a.o psb_sovrl_a.o \ + psb_mgather_a.o psb_mhalo_a.o psb_movrl_a.o \ + psb_egather_a.o psb_ehalo_a.o psb_eovrl_a.o \ + psb_cgather_a.o psb_chalo_a.o psb_covrl_a.o \ + psb_zgather_a.o psb_zhalo_a.o psb_zovrl_a.o -MPFOBJS=psb_dscatter.o psb_zscatter.o psb_iscatter.o psb_cscatter.o psb_sscatter.o\ - psb_dspgather.o psb_sspgather.o psb_zspgather.o psb_cspgather.o +MPFOBJS=psb_dscatter.o psb_zscatter.o \ + psb_iscatter.o psb_lscatter.o \ + psb_cscatter.o psb_sscatter.o \ + psb_dscatter_a.o psb_zscatter_a.o \ + psb_mscatter_a.o psb_escatter_a.o \ + psb_cscatter_a.o psb_sscatter_a.o \ + psb_dspgather.o psb_sspgather.o \ + psb_zspgather.o psb_cspgather.o LIBDIR=.. INCDIR=.. MODDIR=../modules diff --git a/base/comm/internals/Makefile b/base/comm/internals/Makefile index c6a7155be..45a7ad46f 100644 --- a/base/comm/internals/Makefile +++ b/base/comm/internals/Makefile @@ -1,16 +1,30 @@ include ../../../Make.inc FOBJS = psi_iovrl_restr.o psi_iovrl_save.o psi_iovrl_upd.o \ + psi_lovrl_restr.o psi_lovrl_save.o psi_lovrl_upd.o \ psi_sovrl_restr.o psi_sovrl_save.o psi_sovrl_upd.o \ psi_dovrl_restr.o psi_dovrl_save.o psi_dovrl_upd.o \ psi_covrl_restr.o psi_covrl_save.o psi_covrl_upd.o \ - psi_zovrl_restr.o psi_zovrl_save.o psi_zovrl_upd.o + psi_zovrl_restr.o psi_zovrl_save.o psi_zovrl_upd.o \ + psi_movrl_restr_a.o psi_movrl_save_a.o psi_movrl_upd_a.o \ + psi_eovrl_restr_a.o psi_eovrl_save_a.o psi_eovrl_upd_a.o \ + psi_sovrl_restr_a.o psi_sovrl_save_a.o psi_sovrl_upd_a.o \ + psi_dovrl_restr_a.o psi_dovrl_save_a.o psi_dovrl_upd_a.o \ + psi_covrl_restr_a.o psi_covrl_save_a.o psi_covrl_upd_a.o \ + psi_zovrl_restr_a.o psi_zovrl_save_a.o psi_zovrl_upd_a.o MPFOBJS = psi_dswapdata.o psi_dswaptran.o\ psi_sswapdata.o psi_sswaptran.o \ psi_iswapdata.o psi_iswaptran.o \ + psi_lswapdata.o psi_lswaptran.o \ psi_cswapdata.o psi_cswaptran.o \ - psi_zswapdata.o psi_zswaptran.o + psi_zswapdata.o psi_zswaptran.o \ + psi_dswapdata_a.o psi_dswaptran_a.o \ + psi_sswapdata_a.o psi_sswaptran_a.o \ + psi_mswapdata_a.o psi_mswaptran_a.o \ + psi_eswapdata_a.o psi_eswaptran_a.o \ + psi_cswapdata_a.o psi_cswaptran_a.o \ + psi_zswapdata_a.o psi_zswaptran_a.o LIBDIR=../.. INCDIR=../.. MODDIR=../../modules diff --git a/base/comm/internals/psi_covrl_restr.f90 b/base/comm/internals/psi_covrl_restr.f90 index 460df8311..98ecdd8be 100644 --- a/base/comm/internals/psi_covrl_restr.f90 +++ b/base/comm/internals/psi_covrl_restr.f90 @@ -29,95 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_covrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_restrr1 - - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_covrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_covrl_restrr1 - -subroutine psi_covrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_restrr2 - - implicit none - - complex(psb_spk_), intent(inout) :: x(:,:) - complex(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_covrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_covrl_restrr2 - subroutine psi_covrl_restr_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_covrl_restr_vect @@ -135,9 +46,11 @@ subroutine psi_covrl_restr_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_covrl_restr_vect' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -175,9 +88,11 @@ subroutine psi_covrl_restr_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_covrl_restr_mv' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_covrl_restr_a.f90 b/base/comm/internals/psi_covrl_restr_a.f90 new file mode 100644 index 000000000..46eb05636 --- /dev/null +++ b/base/comm/internals/psi_covrl_restr_a.f90 @@ -0,0 +1,124 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_covrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_restrr1 + + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_restrr1 + +subroutine psi_covrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_restrr2 + + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_restrr2 + diff --git a/base/comm/internals/psi_covrl_save.f90 b/base/comm/internals/psi_covrl_save.f90 index bb1d64609..41e659437 100644 --- a/base/comm/internals/psi_covrl_save.f90 +++ b/base/comm/internals/psi_covrl_save.f90 @@ -29,108 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - -subroutine psi_covrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_saver1 - - use psb_realloc_mod - - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_covrl_saver1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_covrl_saver1 - - -subroutine psi_covrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_covrl_saver2 - - use psb_realloc_mod - - implicit none - - complex(psb_spk_), intent(inout) :: x(:,:) - complex(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_covrl_saver2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_covrl_saver2 - - subroutine psi_covrl_save_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_covrl_save_vect use psb_realloc_mod @@ -148,9 +46,11 @@ subroutine psi_covrl_save_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -196,9 +96,11 @@ subroutine psi_covrl_save_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_covrl_save_a.f90 b/base/comm/internals/psi_covrl_save_a.f90 new file mode 100644 index 000000000..d853db8df --- /dev/null +++ b/base/comm/internals/psi_covrl_save_a.f90 @@ -0,0 +1,135 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +subroutine psi_covrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_saver1 + + use psb_realloc_mod + + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_covrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_saver1 + + +subroutine psi_covrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_covrl_saver2 + + use psb_realloc_mod + + implicit none + + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_covrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_saver2 diff --git a/base/comm/internals/psi_covrl_upd.f90 b/base/comm/internals/psi_covrl_upd.f90 index cc341fb4e..f99cbb664 100644 --- a/base/comm/internals/psi_covrl_upd.f90 +++ b/base/comm/internals/psi_covrl_upd.f90 @@ -29,139 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_covrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_covrl_updr1 - - implicit none - - complex(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_covrl_updr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = czero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_covrl_updr1 - - -subroutine psi_covrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_covrl_updr2 - - implicit none - - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_covrl_updr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = czero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_covrl_updr2 - subroutine psi_covrl_upd_vect(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_covrl_upd_vect @@ -183,9 +50,11 @@ subroutine psi_covrl_upd_vect(x,desc_a,update,info) name='psi_covrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -262,9 +131,11 @@ subroutine psi_covrl_upd_multivect(x,desc_a,update,info) name='psi_covrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_covrl_upd_a.f90 b/base/comm/internals/psi_covrl_upd_a.f90 new file mode 100644 index 000000000..633747e56 --- /dev/null +++ b/base/comm/internals/psi_covrl_upd_a.f90 @@ -0,0 +1,167 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_covrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_covrl_updr1 + + implicit none + + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_covrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_updr1 + + +subroutine psi_covrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_covrl_updr2 + + implicit none + + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_covrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = czero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_covrl_updr2 diff --git a/base/comm/internals/psi_cswapdata.F90 b/base/comm/internals/psi_cswapdata.F90 index 59bfcb152..4b5e0f617 100644 --- a/base/comm/internals/psi_cswapdata.F90 +++ b/base/comm/internals/psi_cswapdata.F90 @@ -83,917 +83,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_cswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_cswapdatam - -subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_cswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_spk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_complex_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_complex_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_cswapidxm - -! -! -! Subroutine: psi_cswapdatav -! Does the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_cswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_cswapdatav - - -! -! -! Subroutine: psi_cswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_cswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_spk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_complex_swap_tag - - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_cswapidxv ! ! ! Subroutine: psi_cswapdata_vect @@ -1113,13 +202,12 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1158,8 +246,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1229,9 +316,8 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1246,8 +332,7 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1266,18 +351,16 @@ subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1456,13 +539,12 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1503,8 +585,7 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1576,9 +657,8 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1594,8 +674,7 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1613,18 +692,16 @@ subroutine psi_cswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_cswapdata_a.F90 b/base/comm/internals/psi_cswapdata_a.F90 new file mode 100644 index 000000000..d0b06fa3c --- /dev/null +++ b/base/comm/internals/psi_cswapdata_a.F90 @@ -0,0 +1,988 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_cswapdata.F90 +! +! Subroutine: psi_cswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswapdatam + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_cswapdatam + +subroutine psi_cswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_cswapidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_c_spk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_c_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_complex_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_complex_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_cswapidxm + +! +! +! Subroutine: psi_cswapdatav +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswapdatav + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_cswapdatav + + +! +! +! Subroutine: psi_cswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_cswapidxv(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_cswapidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_c_spk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_c_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_complex_swap_tag + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_complex_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_cswapidxv diff --git a/base/comm/internals/psi_cswaptran.F90 b/base/comm/internals/psi_cswaptran.F90 index f47a26c85..2953783a7 100644 --- a/base/comm/internals/psi_cswaptran.F90 +++ b/base/comm/internals/psi_cswaptran.F90 @@ -87,932 +87,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_cswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_cswaptranm - -subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ctranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_complex_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_ctranidxm -! -! -! Subroutine: psi_cswaptranv -! Does the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_cswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_cswaptranv - - -! -! -! Subroutine: psi_ctranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ctranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_complex_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_spk_,prcid(i),& - & p2ptag, icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_complex_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_ctranidxv -! ! ! Subroutine: psi_cswaptran_vect ! Data exchange among processes. @@ -1046,7 +120,6 @@ subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1132,13 +205,12 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1178,8 +250,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1254,9 +325,8 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1271,8 +341,7 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1291,18 +360,16 @@ subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1401,7 +468,6 @@ subroutine psi_cswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1486,13 +552,12 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1533,8 +598,7 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1608,9 +672,8 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1626,8 +689,7 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1645,18 +707,16 @@ subroutine psi_ctran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_cswaptran_a.F90 b/base/comm/internals/psi_cswaptran_a.F90 new file mode 100644 index 000000000..4a8b25952 --- /dev/null +++ b/base/comm/internals/psi_cswaptran_a.F90 @@ -0,0 +1,1004 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_cswaptran.F90 +! +! Subroutine: psi_cswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswaptranm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_cswaptranm + +subroutine psi_ctranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ctranidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_c_spk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_complex_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_ctranidxm +! +! +! Subroutine: psi_cswaptranv +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_cswaptranv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_cswaptranv + + +! +! +! Subroutine: psi_ctranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_ctranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ctranidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_c_spk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_c_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_complex_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_spk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_complex_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_ctranidxv diff --git a/base/comm/internals/psi_dovrl_restr.f90 b/base/comm/internals/psi_dovrl_restr.f90 index bda2d7d11..326f32df0 100644 --- a/base/comm/internals/psi_dovrl_restr.f90 +++ b/base/comm/internals/psi_dovrl_restr.f90 @@ -29,95 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_dovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_restrr1 - - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_dovrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dovrl_restrr1 - -subroutine psi_dovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_restrr2 - - implicit none - - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_dovrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dovrl_restrr2 - subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_dovrl_restr_vect @@ -135,9 +46,11 @@ subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_restr_vect' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -175,9 +88,11 @@ subroutine psi_dovrl_restr_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_restr_mv' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_dovrl_restr_a.f90 b/base/comm/internals/psi_dovrl_restr_a.f90 new file mode 100644 index 000000000..2d83c416d --- /dev/null +++ b/base/comm/internals/psi_dovrl_restr_a.f90 @@ -0,0 +1,124 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_dovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_restrr1 + + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_restrr1 + +subroutine psi_dovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_restrr2 + + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_restrr2 + diff --git a/base/comm/internals/psi_dovrl_save.f90 b/base/comm/internals/psi_dovrl_save.f90 index 1c637fa43..3f8a923b3 100644 --- a/base/comm/internals/psi_dovrl_save.f90 +++ b/base/comm/internals/psi_dovrl_save.f90 @@ -29,108 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - -subroutine psi_dovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_saver1 - - use psb_realloc_mod - - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dovrl_saver1 - - -subroutine psi_dovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_dovrl_saver2 - - use psb_realloc_mod - - implicit none - - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_dovrl_saver2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dovrl_saver2 - - subroutine psi_dovrl_save_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_dovrl_save_vect use psb_realloc_mod @@ -148,9 +46,11 @@ subroutine psi_dovrl_save_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -196,9 +96,11 @@ subroutine psi_dovrl_save_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_dovrl_save_a.f90 b/base/comm/internals/psi_dovrl_save_a.f90 new file mode 100644 index 000000000..6bf57d87d --- /dev/null +++ b/base/comm/internals/psi_dovrl_save_a.f90 @@ -0,0 +1,135 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +subroutine psi_dovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_saver1 + + use psb_realloc_mod + + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_saver1 + + +subroutine psi_dovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_dovrl_saver2 + + use psb_realloc_mod + + implicit none + + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_saver2 diff --git a/base/comm/internals/psi_dovrl_upd.f90 b/base/comm/internals/psi_dovrl_upd.f90 index 8e18d1688..867281ff5 100644 --- a/base/comm/internals/psi_dovrl_upd.f90 +++ b/base/comm/internals/psi_dovrl_upd.f90 @@ -29,139 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_dovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_dovrl_updr1 - - implicit none - - real(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_dovrl_updr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = dzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dovrl_updr1 - - -subroutine psi_dovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_dovrl_updr2 - - implicit none - - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_dovrl_updr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = dzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dovrl_updr2 - subroutine psi_dovrl_upd_vect(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_dovrl_upd_vect @@ -183,9 +50,11 @@ subroutine psi_dovrl_upd_vect(x,desc_a,update,info) name='psi_dovrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -262,9 +131,11 @@ subroutine psi_dovrl_upd_multivect(x,desc_a,update,info) name='psi_dovrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_dovrl_upd_a.f90 b/base/comm/internals/psi_dovrl_upd_a.f90 new file mode 100644 index 000000000..ccdfba895 --- /dev/null +++ b/base/comm/internals/psi_dovrl_upd_a.f90 @@ -0,0 +1,167 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_dovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_dovrl_updr1 + + implicit none + + real(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_dovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = dzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_updr1 + + +subroutine psi_dovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_dovrl_updr2 + + implicit none + + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_dovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = dzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dovrl_updr2 diff --git a/base/comm/internals/psi_dswapdata.F90 b/base/comm/internals/psi_dswapdata.F90 index b5ea58db8..ff0845e66 100644 --- a/base/comm/internals/psi_dswapdata.F90 +++ b/base/comm/internals/psi_dswapdata.F90 @@ -83,917 +83,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_dswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dswapdatam - -subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_dswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_r_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_r_dpk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_double_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_double_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_dswapidxm - -! -! -! Subroutine: psi_dswapdatav -! Does the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_dswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dswapdatav - - -! -! -! Subroutine: psi_dswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_dswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_r_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_r_dpk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_double_swap_tag - - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_double_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_dswapidxv ! ! ! Subroutine: psi_dswapdata_vect @@ -1113,13 +202,12 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1158,8 +246,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1229,9 +316,8 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1246,8 +332,7 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1266,18 +351,16 @@ subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1456,13 +539,12 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1503,8 +585,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1576,9 +657,8 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1594,8 +674,7 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1613,18 +692,16 @@ subroutine psi_dswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_dswapdata_a.F90 b/base/comm/internals/psi_dswapdata_a.F90 new file mode 100644 index 000000000..ec330ef75 --- /dev/null +++ b/base/comm/internals/psi_dswapdata_a.F90 @@ -0,0 +1,988 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_dswapdata.F90 +! +! Subroutine: psi_dswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_dswapdatam + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dswapdatam + +subroutine psi_dswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_dswapidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_r_dpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_r_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_double_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_double_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_dswapidxm + +! +! +! Subroutine: psi_dswapdatav +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_dswapdatav + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dswapdatav + + +! +! +! Subroutine: psi_dswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_dswapidxv(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_dswapidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_r_dpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_r_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_double_swap_tag + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_double_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_dswapidxv diff --git a/base/comm/internals/psi_dswaptran.F90 b/base/comm/internals/psi_dswaptran.F90 index 1beebf5ef..179e083a2 100644 --- a/base/comm/internals/psi_dswaptran.F90 +++ b/base/comm/internals/psi_dswaptran.F90 @@ -87,932 +87,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_dswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dswaptranm - -subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_dtranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_r_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_double_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_dtranidxm -! -! -! Subroutine: psi_dswaptranv -! Does the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_dswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_dswaptranv - - -! -! -! Subroutine: psi_dtranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_dtranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_r_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_double_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_dpk_,prcid(i),& - & p2ptag, icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_double_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_dtranidxv -! ! ! Subroutine: psi_dswaptran_vect ! Data exchange among processes. @@ -1046,7 +120,6 @@ subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1132,13 +205,12 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1178,8 +250,7 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1254,9 +325,8 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1271,8 +341,7 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1291,18 +360,16 @@ subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1401,7 +468,6 @@ subroutine psi_dswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1486,13 +552,12 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1533,8 +598,7 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1608,9 +672,8 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1626,8 +689,7 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1645,18 +707,16 @@ subroutine psi_dtran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_dswaptran_a.F90 b/base/comm/internals/psi_dswaptran_a.F90 new file mode 100644 index 000000000..ba648a15c --- /dev/null +++ b/base/comm/internals/psi_dswaptran_a.F90 @@ -0,0 +1,1004 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_dswaptran.F90 +! +! Subroutine: psi_dswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_dswaptranm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dswaptranm + +subroutine psi_dtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_dtranidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_r_dpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_double_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_dtranidxm +! +! +! Subroutine: psi_dswaptranv +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_dswaptranv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_dswaptranv + + +! +! +! Subroutine: psi_dtranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_dtranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_dtranidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_r_dpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_r_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_double_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_dpk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_double_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_dtranidxv diff --git a/base/comm/internals/psi_eovrl_restr_a.f90 b/base/comm/internals/psi_eovrl_restr_a.f90 new file mode 100644 index 000000000..fe981855c --- /dev/null +++ b/base/comm/internals/psi_eovrl_restr_a.f90 @@ -0,0 +1,124 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_eovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_eovrl_restrr1 + + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_eovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eovrl_restrr1 + +subroutine psi_eovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_eovrl_restrr2 + + implicit none + + integer(psb_epk_), intent(inout) :: x(:,:) + integer(psb_epk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_eovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eovrl_restrr2 + diff --git a/base/comm/internals/psi_eovrl_save_a.f90 b/base/comm/internals/psi_eovrl_save_a.f90 new file mode 100644 index 000000000..de6878f09 --- /dev/null +++ b/base/comm/internals/psi_eovrl_save_a.f90 @@ -0,0 +1,135 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +subroutine psi_eovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_eovrl_saver1 + + use psb_realloc_mod + + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_eovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eovrl_saver1 + + +subroutine psi_eovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_eovrl_saver2 + + use psb_realloc_mod + + implicit none + + integer(psb_epk_), intent(inout) :: x(:,:) + integer(psb_epk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_eovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eovrl_saver2 diff --git a/base/comm/internals/psi_eovrl_upd_a.f90 b/base/comm/internals/psi_eovrl_upd_a.f90 new file mode 100644 index 000000000..f8589e413 --- /dev/null +++ b/base/comm/internals/psi_eovrl_upd_a.f90 @@ -0,0 +1,167 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_eovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_eovrl_updr1 + + implicit none + + integer(psb_epk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_eovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = ezero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eovrl_updr1 + + +subroutine psi_eovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_eovrl_updr2 + + implicit none + + integer(psb_epk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_eovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = ezero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eovrl_updr2 diff --git a/base/comm/internals/psi_eswapdata_a.F90 b/base/comm/internals/psi_eswapdata_a.F90 new file mode 100644 index 000000000..a697ad914 --- /dev/null +++ b/base/comm/internals/psi_eswapdata_a.F90 @@ -0,0 +1,988 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_eswapdata.F90 +! +! Subroutine: psi_eswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_eswapdatam + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eswapdatam + +subroutine psi_eswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_eswapidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_epk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_epk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int8_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int8_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_eswapidxm + +! +! +! Subroutine: psi_eswapdatav +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_eswapdatav + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eswapdatav + + +! +! +! Subroutine: psi_eswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_eswapidxv(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_eswapidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_epk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_epk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int8_swap_tag + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int8_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_eswapidxv diff --git a/base/comm/internals/psi_eswaptran_a.F90 b/base/comm/internals/psi_eswaptran_a.F90 new file mode 100644 index 000000000..dec5932e9 --- /dev/null +++ b/base/comm/internals/psi_eswaptran_a.F90 @@ -0,0 +1,1004 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_eswaptran.F90 +! +! Subroutine: psi_eswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_eswaptranm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eswaptranm + +subroutine psi_etranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_etranidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_epk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_epk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int8_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_etranidxm +! +! +! Subroutine: psi_eswaptranv +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_eswaptranv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_eswaptranv + + +! +! +! Subroutine: psi_etranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_etranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_etranidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_epk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_epk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_epk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_epk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int8_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_epk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int8_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_etranidxv diff --git a/base/comm/internals/psi_iovrl_restr.f90 b/base/comm/internals/psi_iovrl_restr.f90 index b278ab0a4..89ff5ee08 100644 --- a/base/comm/internals/psi_iovrl_restr.f90 +++ b/base/comm/internals/psi_iovrl_restr.f90 @@ -29,95 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_iovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_iovrl_restrr1 - - implicit none - - integer(psb_ipk_), intent(inout) :: x(:) - integer(psb_ipk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_iovrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iovrl_restrr1 - -subroutine psi_iovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_iovrl_restrr2 - - implicit none - - integer(psb_ipk_), intent(inout) :: x(:,:) - integer(psb_ipk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_iovrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iovrl_restrr2 - subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_iovrl_restr_vect @@ -135,9 +46,11 @@ subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_iovrl_restr_vect' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -175,9 +88,11 @@ subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_iovrl_restr_mv' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_iovrl_save.f90 b/base/comm/internals/psi_iovrl_save.f90 index 9d95ee95b..b48a7dbcf 100644 --- a/base/comm/internals/psi_iovrl_save.f90 +++ b/base/comm/internals/psi_iovrl_save.f90 @@ -29,108 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - -subroutine psi_iovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_iovrl_saver1 - - use psb_realloc_mod - - implicit none - - integer(psb_ipk_), intent(inout) :: x(:) - integer(psb_ipk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_iovrl_saver1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iovrl_saver1 - - -subroutine psi_iovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_iovrl_saver2 - - use psb_realloc_mod - - implicit none - - integer(psb_ipk_), intent(inout) :: x(:,:) - integer(psb_ipk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_iovrl_saver2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iovrl_saver2 - - subroutine psi_iovrl_save_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_iovrl_save_vect use psb_realloc_mod @@ -148,9 +46,11 @@ subroutine psi_iovrl_save_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -196,9 +96,11 @@ subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_iovrl_upd.f90 b/base/comm/internals/psi_iovrl_upd.f90 index ad9cca3b5..a84a1cc08 100644 --- a/base/comm/internals/psi_iovrl_upd.f90 +++ b/base/comm/internals/psi_iovrl_upd.f90 @@ -29,139 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_iovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_iovrl_updr1 - - implicit none - - integer(psb_ipk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_iovrl_updr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = izero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iovrl_updr1 - - -subroutine psi_iovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_iovrl_updr2 - - implicit none - - integer(psb_ipk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_iovrl_updr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = izero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iovrl_updr2 - subroutine psi_iovrl_upd_vect(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_iovrl_upd_vect @@ -183,9 +50,11 @@ subroutine psi_iovrl_upd_vect(x,desc_a,update,info) name='psi_iovrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -262,9 +131,11 @@ subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) name='psi_iovrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_iswapdata.F90 b/base/comm/internals/psi_iswapdata.F90 index 890237cd8..4fa0fffb6 100644 --- a/base/comm/internals/psi_iswapdata.F90 +++ b/base/comm/internals/psi_iswapdata.F90 @@ -83,917 +83,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_iswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:,:), beta - integer(psb_ipk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iswapdatam - -subroutine psi_iswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_iswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:,:), beta - integer(psb_ipk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_ipk_integer,rcvbuf,rvsz,& - & brvidx,psb_mpi_ipk_integer,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_iswapidxm - -! -! -! Subroutine: psi_iswapdatav -! Does the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_iswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:), beta - integer(psb_ipk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iswapdatav - - -! -! -! Subroutine: psi_iswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_iswapidxv(iictxt,iicomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_iswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:), beta - integer(psb_ipk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_ipk_integer,rcvbuf,rvsz,& - & brvidx,psb_mpi_ipk_integer,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int_swap_tag - - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_iswapidxv ! ! ! Subroutine: psi_iswapdata_vect @@ -1113,13 +202,12 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1158,8 +246,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1181,7 +268,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_int_swap_tag call mpi_irecv(y%combuf(rcv_pt),nerv,& - & psb_mpi_ipk_integer,prcid(i),& + & psb_mpi_ipk_,prcid(i),& & p2ptag, icomm,y%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 @@ -1224,14 +311,13 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if ((nesd>0).and.(proc_to_comm /= me)) then call mpi_isend(y%combuf(snd_pt),nesd,& - & psb_mpi_ipk_integer,prcid(i),& + & psb_mpi_ipk_,prcid(i),& & p2ptag,icomm,y%comid(i,1),iret) end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1246,8 +332,7 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1266,18 +351,16 @@ subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1456,13 +539,12 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1503,8 +585,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1526,7 +607,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt p2ptag = psb_int_swap_tag call mpi_irecv(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_ipk_integer,prcid(i),& + & psb_mpi_ipk_,prcid(i),& & p2ptag, icomm,y%comid(i,2),iret) end if rcv_pt = rcv_pt + n*nerv @@ -1571,14 +652,13 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & if ((nesd>0).and.(proc_to_comm /= me)) then call mpi_isend(y%combuf(snd_pt),n*nesd,& - & psb_mpi_ipk_integer,prcid(i),& + & psb_mpi_ipk_,prcid(i),& & p2ptag,icomm,y%comid(i,1),iret) end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1594,8 +674,7 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1613,18 +692,16 @@ subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_iswaptran.F90 b/base/comm/internals/psi_iswaptran.F90 index 25b13fe94..6985b7c5c 100644 --- a/base/comm/internals/psi_iswaptran.F90 +++ b/base/comm/internals/psi_iswaptran.F90 @@ -87,932 +87,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_iswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:,:), beta - integer(psb_ipk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iswaptranm - -subroutine psi_itranidxm(iictxt,iicomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_itranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:,:), beta - integer(psb_ipk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_ipk_integer,& - & sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_int_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_itranidxm -! -! -! Subroutine: psi_iswaptranv -! Does the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_iswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:), beta - integer(psb_ipk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_iswaptranv - - -! -! -! Subroutine: psi_itranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_itranidxv(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_itranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:), beta - integer(psb_ipk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - integer(psb_ipk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_ipk_integer,& - & sndbuf,sdsz,bsdidx,psb_mpi_ipk_integer,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_int_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_ipk_integer,prcid(i),& - & p2ptag, icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_int_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_itranidxv -! ! ! Subroutine: psi_iswaptran_vect ! Data exchange among processes. @@ -1046,7 +120,6 @@ subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1132,13 +205,12 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1178,8 +250,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1202,7 +273,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt call mpi_irecv(y%combuf(snd_pt),nesd,& - & psb_mpi_ipk_integer,prcid(i),& + & psb_mpi_ipk_,prcid(i),& & p2ptag, icomm,y%comid(i,2),iret) end if pnti = pnti + nerv + nesd + 3 @@ -1249,14 +320,13 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if ((nerv>0).and.(proc_to_comm /= me)) then call mpi_isend(y%combuf(rcv_pt),nerv,& - & psb_mpi_ipk_integer,prcid(i),& + & psb_mpi_ipk_,prcid(i),& & p2ptag,icomm,y%comid(i,1),iret) end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1271,8 +341,7 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1291,18 +360,16 @@ subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1401,7 +468,6 @@ subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1486,13 +552,12 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1533,8 +598,7 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1556,7 +620,7 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if ((nesd>0).and.(proc_to_comm /= me)) then if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt call mpi_irecv(y%combuf(snd_pt),n*nesd,& - & psb_mpi_ipk_integer,prcid(i),& + & psb_mpi_ipk_,prcid(i),& & p2ptag, icomm,y%comid(i,2),iret) end if rcv_pt = rcv_pt + n*nerv @@ -1603,14 +667,13 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if ((nerv>0).and.(proc_to_comm /= me)) then call mpi_isend(y%combuf(rcv_pt),n*nerv,& - & psb_mpi_ipk_integer,prcid(i),& + & psb_mpi_ipk_,prcid(i),& & p2ptag,icomm,y%comid(i,1),iret) end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1626,8 +689,7 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1645,18 +707,16 @@ subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_lovrl_restr.f90 b/base/comm/internals/psi_lovrl_restr.f90 new file mode 100644 index 000000000..ba96e9c0b --- /dev/null +++ b/base/comm/internals/psi_lovrl_restr.f90 @@ -0,0 +1,115 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_lovrl_restr_vect + use psb_l_base_vect_mod + + implicit none + + class(psb_l_base_vect_type) :: x + integer(psb_lpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_lovrl_restr_vect' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lovrl_restr_vect + + +subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_lovrl_restr_multivect + use psb_l_base_vect_mod + + implicit none + + class(psb_l_base_multivect_type) :: x + integer(psb_lpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_lovrl_restr_mv' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call x%sct(isz,desc_a%ovrlap_elem(:,1),xs,lzero) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lovrl_restr_multivect + + diff --git a/base/comm/internals/psi_lovrl_save.f90 b/base/comm/internals/psi_lovrl_save.f90 new file mode 100644 index 000000000..5a06c6973 --- /dev/null +++ b/base/comm/internals/psi_lovrl_save.f90 @@ -0,0 +1,129 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_lovrl_save_vect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_lovrl_save_vect + use psb_realloc_mod + use psb_l_base_vect_mod + + implicit none + + class(psb_l_base_vect_type) :: x + integer(psb_lpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lovrl_save_vect + + + +subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_lovrl_save_multivect + use psb_realloc_mod + use psb_l_base_vect_mod + + implicit none + + class(psb_l_base_multivect_type) :: x + integer(psb_lpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_dovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + call x%gth(isz,desc_a%ovrlap_elem(:,1),xs) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lovrl_save_multivect diff --git a/base/comm/internals/psi_lovrl_upd.f90 b/base/comm/internals/psi_lovrl_upd.f90 new file mode 100644 index 000000000..4364ac6f9 --- /dev/null +++ b/base/comm/internals/psi_lovrl_upd.f90 @@ -0,0 +1,194 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +subroutine psi_lovrl_upd_vect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_lovrl_upd_vect + use psb_realloc_mod + use psb_l_base_vect_mod + + implicit none + + class(psb_l_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_lpk_), allocatable :: xs(:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_lovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + nx = size(desc_a%ovrlap_elem,1) + call psb_realloc(nx,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i) = xs(i)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i) = lzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lovrl_upd_vect + +subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_lovrl_upd_multivect + use psb_realloc_mod + use psb_l_base_vect_mod + + implicit none + + class(psb_l_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_lpk_), allocatable :: xs(:,:) + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm, nx, nc + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + + name='psi_lovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + nx = size(desc_a%ovrlap_elem,1) + nc = x%get_ncols() + call psb_realloc(nx,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_Dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (update /= psb_sum_) then + call x%gth(nx,desc_a%ovrlap_elem(:,1),xs) + ! switch on update type + + select case (update) + case(psb_square_root_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,nx + ndm = desc_a%ovrlap_elem(i,2) + xs(i,:) = xs(i,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,nx + if (me /= desc_a%ovrlap_elem(i,3))& + & xs(i,:) = lzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + call x%sct(nx,desc_a%ovrlap_elem(:,1),xs,lzero) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lovrl_upd_multivect diff --git a/base/comm/internals/psi_lswapdata.F90 b/base/comm/internals/psi_lswapdata.F90 new file mode 100644 index 000000000..b409dd405 --- /dev/null +++ b/base/comm/internals/psi_lswapdata.F90 @@ -0,0 +1,766 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_lswapdata.F90 +! +! Subroutine: psi_lswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +! +! +! Subroutine: psi_lswapdata_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +! +subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_lswapdata_vect + use psb_l_base_vect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lswapdata_vect + + +! +! +! Subroutine: psi_lswap_vidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_lswap_vidx_vect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_l_base_vect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_long_swap_tag + call mpi_irecv(y%combuf(rcv_pt),nerv,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + idx_pt = snd_pt + call y%gth(idx_pt,nesd,idx) + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),nesd,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+nerv-1) = y%combuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+nerv-1) + call y%sct(rcv_pt,nerv,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_lswap_vidx_vect + +! +! +! Subroutine: psi_lswapdata_multivect +! Data exchange among processes. +! +! Takes care of Y an encaspulated vector. +! +! +subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_lswapdata_multivect + use psb_l_base_multivect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lswapdata_multivect + + +! +! +! Subroutine: psi_lswap_vidx_multivect +! Data exchange among processes. +! +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods +! of multivectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_lswap_vidx_multivect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_l_base_multivect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n = y%get_ncols() + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + p2ptag = psb_long_swap_tag + call mpi_irecv(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call y%gth(idx_pt,snd_pt,nesd,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + if ((nesd>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(snd_pt),n*nesd,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nesd>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + if (nerv>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(rcv_pt:rcv_pt+n*nerv-1) = y%combuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(rcv_pt:rcv_pt+n*nerv-1) + call y%sct(idx_pt,rcv_pt,nerv,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_lswap_vidx_multivect + diff --git a/base/comm/internals/psi_lswaptran.F90 b/base/comm/internals/psi_lswaptran.F90 new file mode 100644 index 000000000..89ae0441b --- /dev/null +++ b/base/comm/internals/psi_lswaptran.F90 @@ -0,0 +1,787 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_lswaptran.F90 +! +! Subroutine: psi_lswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +! +! Subroutine: psi_lswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. +! +! +subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_lswaptran_vect + use psb_l_base_vect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_lswaptran_vect + + + +! +! +! Subroutine: psi_ltran_vidx_vect +! Data exchange among processes. +! +! Takes care of Y an exanspulated vector. Relies on the gather/scatter methods +! of vectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ltran_vidx_vect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_l_base_vect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),rcv_pt + call mpi_irecv(y%combuf(snd_pt),nesd,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + idx_pt = rcv_pt + call y%gth(idx_pt,nerv,idx) + + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),nerv,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+nesd-1) = y%combuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + snd_pt = 1+pnti+nerv+psb_n_elem_send_ + rcv_pt = 1+pnti+psb_n_elem_recv_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+nesd-1) + call y%sct(snd_pt,nesd,idx,beta) + pnti = pnti + nerv + nesd + 3 + end do + ! + ! Waited for everybody, clean up + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return + +end subroutine psi_ltran_vidx_vect + + +! +! +! +! +! Subroutine: psi_lswaptran_vect +! Data exchange among processes. +! +! Takes care of Y an encaspulated vector. +! +! +subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_lswaptran_multivect + use psb_l_base_vect_mod + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + class(psb_i_base_vect_type), pointer :: d_vidx + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_vidx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_vidx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + end subroutine psi_lswaptran_multivect + + +! +! +! Subroutine: psi_ltran_vidx_multivect +! Data exchange among processes. +! +! Takes care of Y an encapsulated multivector. Relies on the gather/scatter methods +! of multivectors. +! +! The real workhorse: the outer routine will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ltran_vidx_multivect + use psb_error_mod + use psb_realloc_mod + use psb_desc_mod + use psb_penv_mod + use psb_l_base_multivect_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable :: prcid(:) + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false., debug=.false. + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n = y%get_ncols() + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + call idx%sync() + + if (debug) write(*,*) me,'Internal buffer' + if (do_send) then + if (allocated(y%comid)) then + if (any(y%comid /= mpi_request_null)) then + ! + ! Unfinished communication? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + end if + if (debug) write(*,*) me,'do_send start' + call y%new_buffer(ione*size(idx%v),info) + call y%new_comid(totxch,info) + y%comid = mpi_request_null + call psb_realloc(totxch,prcid,info) + ! First I post all the non blocking receives + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + if (debug) write(*,*) me,'Posting receive from',prcid(i),snd_pt + call mpi_irecv(y%combuf(snd_pt),n*nesd,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag, icomm,y%comid(i,2),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' Gather ' + ! + ! Then gather for sending. + ! + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call y%gth(idx_pt,rcv_pt,nerv,idx) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + ! + ! Then wait for device + ! + call y%device_wait() + + if (debug) write(*,*) me,' isend' + ! + ! Then send + ! + + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + if ((nerv>0).and.(proc_to_comm /= me)) then + call mpi_isend(y%combuf(rcv_pt),n*nerv,& + & psb_mpi_lpk_,prcid(i),& + & p2ptag,icomm,y%comid(i,1),iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + end if + + if (do_recv) then + if (debug) write(*,*) me,' do_Recv' + if (.not.allocated(y%comid)) then + ! + ! No matching send? Something is wrong.... + ! + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/-2/)) + goto 9999 + end if + call psb_realloc(totxch,prcid,info) + + if (debug) write(*,*) me,' wait' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + p2ptag = psb_long_swap_tag + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + if (proc_to_comm /= me)then + if (nerv>0) then + call mpi_wait(y%comid(i,1),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + if (nesd>0) then + call mpi_wait(y%comid(i,2),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + y%combuf(snd_pt:snd_pt+n*nesd-1) = y%combuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + if (debug) write(*,*) me,' scatter' + pnti = 1 + snd_pt = totrcv_+1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx%v(pnti+psb_proc_id_) + nerv = idx%v(pnti+psb_n_elem_recv_) + nesd = idx%v(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + + if (debug) write(0,*)me,' Received from: ',prcid(i),& + & y%combuf(snd_pt:snd_pt+n*nesd-1) + call y%sct(idx_pt,snd_pt,nesd,idx,beta) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! + ! Waited for com, cleanup comid + ! + y%comid = mpi_request_null + + ! + ! Then wait for device + ! + if (debug) write(*,*) me,' wait' + call y%device_wait() + if (debug) write(*,*) me,' free buffer' + call y%maybe_free_buffer(info) + if (info == 0) call y%free_comid(info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if (debug) write(*,*) me,' done' + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return + +end subroutine psi_ltran_vidx_multivect + + + + diff --git a/base/comm/internals/psi_movrl_restr_a.f90 b/base/comm/internals/psi_movrl_restr_a.f90 new file mode 100644 index 000000000..a5759f98a --- /dev/null +++ b/base/comm/internals/psi_movrl_restr_a.f90 @@ -0,0 +1,124 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_movrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_movrl_restrr1 + + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_mpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_movrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_movrl_restrr1 + +subroutine psi_movrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_movrl_restrr2 + + implicit none + + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_mpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_movrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_movrl_restrr2 + diff --git a/base/comm/internals/psi_movrl_save_a.f90 b/base/comm/internals/psi_movrl_save_a.f90 new file mode 100644 index 000000000..7935333fa --- /dev/null +++ b/base/comm/internals/psi_movrl_save_a.f90 @@ -0,0 +1,135 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +subroutine psi_movrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_movrl_saver1 + + use psb_realloc_mod + + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_mpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_movrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_movrl_saver1 + + +subroutine psi_movrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_movrl_saver2 + + use psb_realloc_mod + + implicit none + + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_mpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_movrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_movrl_saver2 diff --git a/base/comm/internals/psi_movrl_upd_a.f90 b/base/comm/internals/psi_movrl_upd_a.f90 new file mode 100644 index 000000000..92bfccce3 --- /dev/null +++ b/base/comm/internals/psi_movrl_upd_a.f90 @@ -0,0 +1,167 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_movrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_movrl_updr1 + + implicit none + + integer(psb_mpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_movrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = mzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_movrl_updr1 + + +subroutine psi_movrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_movrl_updr2 + + implicit none + + integer(psb_mpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_movrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = mzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_movrl_updr2 diff --git a/base/comm/internals/psi_mswapdata_a.F90 b/base/comm/internals/psi_mswapdata_a.F90 new file mode 100644 index 000000000..e0f5eeb0d --- /dev/null +++ b/base/comm/internals/psi_mswapdata_a.F90 @@ -0,0 +1,988 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_mswapdata.F90 +! +! Subroutine: psi_mswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_mswapdatam + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_mswapdatam + +subroutine psi_mswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_mswapidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_mpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_mpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int4_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int4_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_mswapidxm + +! +! +! Subroutine: psi_mswapdatav +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_mswapdatav + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_mswapdatav + + +! +! +! Subroutine: psi_mswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_mswapidxv(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_mswapidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_mpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_mpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int4_swap_tag + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int4_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_mswapidxv diff --git a/base/comm/internals/psi_mswaptran_a.F90 b/base/comm/internals/psi_mswaptran_a.F90 new file mode 100644 index 000000000..2283de0b4 --- /dev/null +++ b/base/comm/internals/psi_mswaptran_a.F90 @@ -0,0 +1,1004 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_mswaptran.F90 +! +! Subroutine: psi_mswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_mswaptranm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_mswaptranm + +subroutine psi_mtranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_mtranidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_mpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_mpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_int4_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_mtranidxm +! +! +! Subroutine: psi_mswaptranv +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_mswaptranv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_mswaptranv + + +! +! +! Subroutine: psi_mtranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_mtranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_mtranidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + integer(psb_mpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_mpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_mpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_int4_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_mpk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_int4_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_mtranidxv diff --git a/base/comm/internals/psi_sovrl_restr.f90 b/base/comm/internals/psi_sovrl_restr.f90 index 0054ad4e9..b74c4335c 100644 --- a/base/comm/internals/psi_sovrl_restr.f90 +++ b/base/comm/internals/psi_sovrl_restr.f90 @@ -29,95 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_sovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_restrr1 - - implicit none - - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_sovrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sovrl_restrr1 - -subroutine psi_sovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_restrr2 - - implicit none - - real(psb_spk_), intent(inout) :: x(:,:) - real(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_sovrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sovrl_restrr2 - subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_sovrl_restr_vect @@ -135,9 +46,11 @@ subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_sovrl_restr_vect' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -175,9 +88,11 @@ subroutine psi_sovrl_restr_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_sovrl_restr_mv' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_sovrl_restr_a.f90 b/base/comm/internals/psi_sovrl_restr_a.f90 new file mode 100644 index 000000000..5ff1a9f71 --- /dev/null +++ b/base/comm/internals/psi_sovrl_restr_a.f90 @@ -0,0 +1,124 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_sovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_restrr1 + + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_restrr1 + +subroutine psi_sovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_restrr2 + + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_restrr2 + diff --git a/base/comm/internals/psi_sovrl_save.f90 b/base/comm/internals/psi_sovrl_save.f90 index a118f6bca..a10ae2180 100644 --- a/base/comm/internals/psi_sovrl_save.f90 +++ b/base/comm/internals/psi_sovrl_save.f90 @@ -29,108 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - -subroutine psi_sovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_saver1 - - use psb_realloc_mod - - implicit none - - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_sovrl_saver1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sovrl_saver1 - - -subroutine psi_sovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_sovrl_saver2 - - use psb_realloc_mod - - implicit none - - real(psb_spk_), intent(inout) :: x(:,:) - real(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_sovrl_saver2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sovrl_saver2 - - subroutine psi_sovrl_save_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_sovrl_save_vect use psb_realloc_mod @@ -148,9 +46,11 @@ subroutine psi_sovrl_save_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -196,9 +96,11 @@ subroutine psi_sovrl_save_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_sovrl_save_a.f90 b/base/comm/internals/psi_sovrl_save_a.f90 new file mode 100644 index 000000000..5766dede8 --- /dev/null +++ b/base/comm/internals/psi_sovrl_save_a.f90 @@ -0,0 +1,135 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +subroutine psi_sovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_saver1 + + use psb_realloc_mod + + implicit none + + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_sovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_saver1 + + +subroutine psi_sovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_sovrl_saver2 + + use psb_realloc_mod + + implicit none + + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_sovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_saver2 diff --git a/base/comm/internals/psi_sovrl_upd.f90 b/base/comm/internals/psi_sovrl_upd.f90 index 389ce5209..b95a49ba6 100644 --- a/base/comm/internals/psi_sovrl_upd.f90 +++ b/base/comm/internals/psi_sovrl_upd.f90 @@ -29,139 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_sovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_sovrl_updr1 - - implicit none - - real(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_sovrl_updr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = szero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sovrl_updr1 - - -subroutine psi_sovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_sovrl_updr2 - - implicit none - - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_sovrl_updr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = szero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sovrl_updr2 - subroutine psi_sovrl_upd_vect(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_sovrl_upd_vect @@ -183,9 +50,11 @@ subroutine psi_sovrl_upd_vect(x,desc_a,update,info) name='psi_sovrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -262,9 +131,11 @@ subroutine psi_sovrl_upd_multivect(x,desc_a,update,info) name='psi_sovrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_sovrl_upd_a.f90 b/base/comm/internals/psi_sovrl_upd_a.f90 new file mode 100644 index 000000000..d553b5f7e --- /dev/null +++ b/base/comm/internals/psi_sovrl_upd_a.f90 @@ -0,0 +1,167 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_sovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_sovrl_updr1 + + implicit none + + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_sovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_updr1 + + +subroutine psi_sovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_sovrl_updr2 + + implicit none + + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_sovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = szero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sovrl_updr2 diff --git a/base/comm/internals/psi_sswapdata.F90 b/base/comm/internals/psi_sswapdata.F90 index 72ea75816..56face250 100644 --- a/base/comm/internals/psi_sswapdata.F90 +++ b/base/comm/internals/psi_sswapdata.F90 @@ -83,917 +83,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_sswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sswapdatam - -subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_sswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_r_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_r_spk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_real_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_real_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_sswapidxm - -! -! -! Subroutine: psi_sswapdatav -! Does the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_sswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sswapdatav - - -! -! -! Subroutine: psi_sswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_sswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_r_spk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_r_spk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_real_swap_tag - - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_sswapidxv ! ! ! Subroutine: psi_sswapdata_vect @@ -1113,13 +202,12 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1158,8 +246,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1229,9 +316,8 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1246,8 +332,7 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1266,18 +351,16 @@ subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1456,13 +539,12 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1503,8 +585,7 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1576,9 +657,8 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1594,8 +674,7 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1613,18 +692,16 @@ subroutine psi_sswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_sswapdata_a.F90 b/base/comm/internals/psi_sswapdata_a.F90 new file mode 100644 index 000000000..599c4cfd1 --- /dev/null +++ b/base/comm/internals/psi_sswapdata_a.F90 @@ -0,0 +1,988 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_sswapdata.F90 +! +! Subroutine: psi_sswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswapdatam + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sswapdatam + +subroutine psi_sswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_sswapidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_r_spk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_r_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_real_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_real_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_sswapidxm + +! +! +! Subroutine: psi_sswapdatav +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswapdatav + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sswapdatav + + +! +! +! Subroutine: psi_sswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_sswapidxv(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_sswapidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_r_spk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_r_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_real_swap_tag + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_real_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_sswapidxv diff --git a/base/comm/internals/psi_sswaptran.F90 b/base/comm/internals/psi_sswaptran.F90 index 9fc907e7d..fc9980615 100644 --- a/base/comm/internals/psi_sswaptran.F90 +++ b/base/comm/internals/psi_sswaptran.F90 @@ -87,932 +87,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_sswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sswaptranm - -subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_stranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_r_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_real_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_stranidxm -! -! -! Subroutine: psi_sswaptranv -! Does the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_sswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_sswaptranv - - -! -! -! Subroutine: psi_stranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_stranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_r_spk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_real_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_r_spk_,prcid(i),& - & p2ptag, icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_real_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_stranidxv -! ! ! Subroutine: psi_sswaptran_vect ! Data exchange among processes. @@ -1046,7 +120,6 @@ subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1132,13 +205,12 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1178,8 +250,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1254,9 +325,8 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1271,8 +341,7 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1291,18 +360,16 @@ subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1401,7 +468,6 @@ subroutine psi_sswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1486,13 +552,12 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1533,8 +598,7 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1608,9 +672,8 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1626,8 +689,7 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1645,18 +707,16 @@ subroutine psi_stran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_sswaptran_a.F90 b/base/comm/internals/psi_sswaptran_a.F90 new file mode 100644 index 000000000..1eb8d227a --- /dev/null +++ b/base/comm/internals/psi_sswaptran_a.F90 @@ -0,0 +1,1004 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_sswaptran.F90 +! +! Subroutine: psi_sswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswaptranm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sswaptranm + +subroutine psi_stranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_stranidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_r_spk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_real_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_stranidxm +! +! +! Subroutine: psi_sswaptranv +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_sswaptranv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_sswaptranv + + +! +! +! Subroutine: psi_stranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_stranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_stranidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + real(psb_spk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_r_spk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_r_spk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_real_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_r_spk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_real_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_stranidxv diff --git a/base/comm/internals/psi_zovrl_restr.f90 b/base/comm/internals/psi_zovrl_restr.f90 index c3fa18689..bd83e6186 100644 --- a/base/comm/internals/psi_zovrl_restr.f90 +++ b/base/comm/internals/psi_zovrl_restr.f90 @@ -29,95 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_zovrl_restrr1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_restrr1 - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_zovrl_restrr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx) = xs(i) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zovrl_restrr1 - -subroutine psi_zovrl_restrr2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_restrr2 - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_zovrl_restrr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (size(x,2) /= size(xs,2)) then - info = psb_err_internal_error_ - call psb_errpush(info,name, a_err='Mismacth columns X vs XS') - goto 9999 - endif - - - isz = size(desc_a%ovrlap_elem,1) - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - x(idx,:) = xs(i,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zovrl_restrr2 - subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_zovrl_restr_vect @@ -135,9 +46,11 @@ subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_zovrl_restr_vect' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -175,9 +88,11 @@ subroutine psi_zovrl_restr_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_zovrl_restr_mv' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_zovrl_restr_a.f90 b/base/comm/internals/psi_zovrl_restr_a.f90 new file mode 100644 index 000000000..a0a22a315 --- /dev/null +++ b/base/comm/internals/psi_zovrl_restr_a.f90 @@ -0,0 +1,124 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_zovrl_restrr1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_restrr1 + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_restrr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx) = xs(i) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_restrr1 + +subroutine psi_zovrl_restrr2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_restrr2 + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_restrr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (size(x,2) /= size(xs,2)) then + info = psb_err_internal_error_ + call psb_errpush(info,name, a_err='Mismacth columns X vs XS') + goto 9999 + endif + + + isz = size(desc_a%ovrlap_elem,1) + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + x(idx,:) = xs(i,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_restrr2 + diff --git a/base/comm/internals/psi_zovrl_save.f90 b/base/comm/internals/psi_zovrl_save.f90 index b65d96de6..162385733 100644 --- a/base/comm/internals/psi_zovrl_save.f90 +++ b/base/comm/internals/psi_zovrl_save.f90 @@ -29,108 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - -subroutine psi_zovrl_saver1(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_saver1 - - use psb_realloc_mod - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz - character(len=20) :: name, ch_err - - name='psi_zovrl_saver1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - call psb_realloc(isz,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i) = x(idx) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zovrl_saver1 - - -subroutine psi_zovrl_saver2(x,xs,desc_a,info) - use psi_mod, psi_protect_name => psi_zovrl_saver2 - - use psb_realloc_mod - - implicit none - - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc - character(len=20) :: name, ch_err - - name='psi_zovrl_saver2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - isz = size(desc_a%ovrlap_elem,1) - nc = size(x,2) - call psb_realloc(isz,nc,xs,info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - do i=1, isz - idx = desc_a%ovrlap_elem(i,1) - xs(i,:) = x(idx,:) - end do - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zovrl_saver2 - - subroutine psi_zovrl_save_vect(x,xs,desc_a,info) use psi_mod, psi_protect_name => psi_zovrl_save_vect use psb_realloc_mod @@ -148,9 +46,11 @@ subroutine psi_zovrl_save_vect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -196,9 +96,11 @@ subroutine psi_zovrl_save_multivect(x,xs,desc_a,info) character(len=20) :: name, ch_err name='psi_dovrl_saver1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_zovrl_save_a.f90 b/base/comm/internals/psi_zovrl_save_a.f90 new file mode 100644 index 000000000..32d5d2125 --- /dev/null +++ b/base/comm/internals/psi_zovrl_save_a.f90 @@ -0,0 +1,135 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +subroutine psi_zovrl_saver1(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_saver1 + + use psb_realloc_mod + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz + character(len=20) :: name, ch_err + + name='psi_zovrl_saver1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + call psb_realloc(isz,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i) = x(idx) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_saver1 + + +subroutine psi_zovrl_saver2(x,xs,desc_a,info) + use psi_mod, psi_protect_name => psi_zovrl_saver2 + + use psb_realloc_mod + + implicit none + + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, isz, nc + character(len=20) :: name, ch_err + + name='psi_zovrl_saver2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + isz = size(desc_a%ovrlap_elem,1) + nc = size(x,2) + call psb_realloc(isz,nc,xs,info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + do i=1, isz + idx = desc_a%ovrlap_elem(i,1) + xs(i,:) = x(idx,:) + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_saver2 diff --git a/base/comm/internals/psi_zovrl_upd.f90 b/base/comm/internals/psi_zovrl_upd.f90 index 1c80111d3..83fcf702d 100644 --- a/base/comm/internals/psi_zovrl_upd.f90 +++ b/base/comm/internals/psi_zovrl_upd.f90 @@ -29,139 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_zovrl_updr1(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_zovrl_updr1 - - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_zovrl_updr1' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx) = x(idx)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx) = zzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zovrl_updr1 - - -subroutine psi_zovrl_updr2(x,desc_a,update,info) - use psi_mod, psi_protect_name => psi_zovrl_updr2 - - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - - ! locals - integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name, ch_err - - name='psi_zovrl_updr2' - if (psb_get_errstatus() /= 0) return - info = psb_success_ - call psb_erractionsave(err_act) - ictxt = desc_a%get_context() - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ! switch on update type - select case (update) - case(psb_square_root_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/sqrt(real(ndm)) - end do - case(psb_avg_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - ndm = desc_a%ovrlap_elem(i,2) - x(idx,:) = x(idx,:)/real(ndm) - end do - case(psb_setzero_) - do i=1,size(desc_a%ovrlap_elem,1) - idx = desc_a%ovrlap_elem(i,1) - if (me /= desc_a%ovrlap_elem(i,3))& - & x(idx,:) = zzero - end do - case(psb_sum_) - ! do nothing - - case default - ! wrong value for choice argument - info = psb_err_iarg_invalid_value_ - ierr(1) = 3; ierr(2)=update; - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zovrl_updr2 - subroutine psi_zovrl_upd_vect(x,desc_a,update,info) use psi_mod, psi_protect_name => psi_zovrl_upd_vect @@ -183,9 +50,11 @@ subroutine psi_zovrl_upd_vect(x,desc_a,update,info) name='psi_zovrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then @@ -262,9 +131,11 @@ subroutine psi_zovrl_upd_multivect(x,desc_a,update,info) name='psi_zovrl_updr1' - if (psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() call psb_info(ictxt, me, np) if (np == -1) then diff --git a/base/comm/internals/psi_zovrl_upd_a.f90 b/base/comm/internals/psi_zovrl_upd_a.f90 new file mode 100644 index 000000000..b149addbb --- /dev/null +++ b/base/comm/internals/psi_zovrl_upd_a.f90 @@ -0,0 +1,167 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_zovrl_updr1(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_zovrl_updr1 + + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_zovrl_updr1' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx) = x(idx)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx) = zzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_updr1 + + +subroutine psi_zovrl_updr2(x,desc_a,update,info) + use psi_mod, psi_protect_name => psi_zovrl_updr2 + + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, i, idx, ndm + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psi_zovrl_updr2' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ! switch on update type + select case (update) + case(psb_square_root_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/sqrt(real(ndm)) + end do + case(psb_avg_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + ndm = desc_a%ovrlap_elem(i,2) + x(idx,:) = x(idx,:)/real(ndm) + end do + case(psb_setzero_) + do i=1,size(desc_a%ovrlap_elem,1) + idx = desc_a%ovrlap_elem(i,1) + if (me /= desc_a%ovrlap_elem(i,3))& + & x(idx,:) = zzero + end do + case(psb_sum_) + ! do nothing + + case default + ! wrong value for choice argument + info = psb_err_iarg_invalid_value_ + ierr(1) = 3; ierr(2)=update; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zovrl_updr2 diff --git a/base/comm/internals/psi_zswapdata.F90 b/base/comm/internals/psi_zswapdata.F90 index 73c2dbfca..c3b46b80c 100644 --- a/base/comm/internals/psi_zswapdata.F90 +++ b/base/comm/internals/psi_zswapdata.F90 @@ -83,917 +83,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_zswapdatam - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zswapdatam - -subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_zswapidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_data' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_dpk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send',& - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_dcomplex_swap_tag - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_dcomplex_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*)& - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_zswapidxm - -! -! -! Subroutine: psi_zswapdatav -! Does the data exchange among processes. Essentially this is doing -! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_zswapdatav - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act - integer(psb_ipk_), pointer :: d_idx(:) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zswapdatav - - -! -! -! Subroutine: psi_zswapdataidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_zswapidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_datav' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - do i=1, totxch - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& - & y,sndbuf(snd_pt:snd_pt+nesd-1)) - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(sndbuf,sdsz,bsdidx,& - & psb_mpi_c_dpk_,rcvbuf,rvsz,& - & brvidx,psb_mpi_c_dpk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_dcomplex_swap_tag - - if ((nesd>0).and.(proc_to_comm /= me)) then - if (usersend) then - call mpi_rsend(sndbuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(sndbuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag - - if ((proc_to_comm /= me).and.(nerv>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swapdata: mismatch on self send', & - & nerv,nesd - end if - rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_snd(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_rcv(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& - & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_zswapidxv ! ! ! Subroutine: psi_zswapdata_vect @@ -1113,13 +202,12 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1158,8 +246,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1229,9 +316,8 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1246,8 +332,7 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1266,18 +351,16 @@ subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1456,13 +539,12 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1503,8 +585,7 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1576,9 +657,8 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1594,8 +674,7 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1613,18 +692,16 @@ subroutine psi_zswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx, & if (nesd>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nerv>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_zswapdata_a.F90 b/base/comm/internals/psi_zswapdata_a.F90 new file mode 100644 index 000000000..1021c9760 --- /dev/null +++ b/base/comm/internals/psi_zswapdata_a.F90 @@ -0,0 +1,988 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_zswapdata.F90 +! +! Subroutine: psi_zswapdatam +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a send on (PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_zswapdatam + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zswapdatam + +subroutine psi_zswapidxm(iictxt,iicomm,flag,n,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_zswapidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_data' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+n*nesd-1)) + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_c_dpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_c_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send',& + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_dcomplex_swap_tag + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_dcomplex_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*)& + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+n*nerv-1) = sndbuf(snd_pt:snd_pt+n*nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_zswapidxm + +! +! +! Subroutine: psi_zswapdatav +! Does the data exchange among processes. Essentially this is doing +! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_zswapdatav + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, data_, err_act + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swapdata(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zswapdatav + + +! +! +! Subroutine: psi_zswapdataidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_zswapidxv(iictxt,iicomm,flag,beta,y,idx, & + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_zswapidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_datav' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + do i=1, totxch + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_gth(nesd,idx(idx_pt:idx_pt+nesd-1),& + & y,sndbuf(snd_pt:snd_pt+nesd-1)) + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(sndbuf,sdsz,bsdidx,& + & psb_mpi_c_dpk_,rcvbuf,rvsz,& + & brvidx,psb_mpi_c_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_dcomplex_swap_tag + + if ((nesd>0).and.(proc_to_comm /= me)) then + if (usersend) then + call mpi_rsend(sndbuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(sndbuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_dcomplex_swap_tag + + if ((proc_to_comm /= me).and.(nerv>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swapdata: mismatch on self send', & + & nerv,nesd + end if + rcvbuf(rcv_pt:rcv_pt+nerv-1) = sndbuf(snd_pt:snd_pt+nesd-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_snd(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_rcv(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + call psi_sct(nerv,idx(idx_pt:idx_pt+nerv-1),& + & rcvbuf(rcv_pt:rcv_pt+nerv-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_zswapidxv diff --git a/base/comm/internals/psi_zswaptran.F90 b/base/comm/internals/psi_zswaptran.F90 index b6b3fe3b5..9be2722d0 100644 --- a/base/comm/internals/psi_zswaptran.F90 +++ b/base/comm/internals/psi_zswaptran.F90 @@ -87,932 +87,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_zswaptranm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if(present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zswaptranm - -subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ztranidxm - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = n*nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = n*nesd - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) - - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(sndbuf(snd_pt),n*nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),n*nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - p2ptag = psb_dcomplex_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send',& - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) - rcv_pt = rcv_pt + n*nerv - snd_pt = snd_pt + n*nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_ztranidxm -! -! -! Subroutine: psi_zswaptranv -! Does the data exchange among processes. This is similar to Xswapdata, but -! the list is read "in reverse", i.e. indices that are normally SENT are used -! for the RECEIVE part and vice-versa. This is the basic data exchange operation -! for doing the product of a sparse matrix by a vector. -! Essentially this is doing a variable all-to-all data exchange -! (ALLTOALLV in MPI parlance), but -! it is capable of pruning empty exchanges, which are very likely in out -! application environment. All the variants have the same structure -! In all these subroutines X may be: I Integer -! S real(psb_spk_) -! D real(psb_dpk_) -! C complex(psb_spk_) -! Z complex(psb_dpk_) -! Basically the operation is as follows: on each process, we identify -! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); -! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y -! but only on the elements involved in the UNPACK operation. -! Thus: for halo data exchange, the receive section is confined in the -! halo indices, and BETA=0, whereas for overlap exchange the receive section -! is scattered in the owned indices, and BETA=1. -! -! Arguments: -! flag - integer Choose the algorithm for data exchange: -! this is chosen through bit fields. -! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! swap_sync = iand(flag,psb_swap_sync_) /= 0 -! swap_send = iand(flag,psb_swap_send_) /= 0 -! swap_recv = iand(flag,psb_swap_recv_) /= 0 -! if (swap_mpi): use underlying MPI_ALLTOALLV. -! if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -! n - integer Number of columns in Y -! beta - X Choose overwrite or sum. -! y(:) - X The data area -! desc_a - type(psb_desc_type). The communication descriptor. -! work(:) - X Buffer space. If not sufficient, will do -! our own internal allocation. -! info - integer. return code. -! data - integer which list is to be used to exchange data -! default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) - - use psi_mod, psb_protect_name => psi_zswaptranv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_), target :: work(:) - type(psb_desc_type),target :: desc_a - integer(psb_ipk_), optional :: data - - ! locals - integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ - integer(psb_ipk_), pointer :: d_idx(:) - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tranv' - call psb_erractionsave(err_act) - - ictxt = desc_a%get_context() - icomm = desc_a%get_mpic() - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.psb_is_asb_desc(desc_a)) then - info=psb_err_invalid_cd_state_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - end if - - call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') - goto 9999 - end if - - call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) - if (info /= psb_success_) goto 9999 - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return -end subroutine psi_zswaptranv - - -! -! -! Subroutine: psi_ztranidxv -! Does the data exchange among processes. -! -! The real workhorse: the outer routines will only choose the index list -! this one takes the index list and does the actual exchange. -! -! -! -subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - - use psi_mod, psb_protect_name => psi_ztranidxv - use psb_error_mod - use psb_desc_mod - use psb_penv_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_), target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv - - ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& - & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable, dimension(:) :: bsdidx, brvidx,& - & sdsz, rvsz, prcid, rvhd, sdhd - integer(psb_ipk_) :: nesd, nerv,& - & err_act, i, idx_pt, totsnd_, totrcv_,& - & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) - logical :: swap_mpi, swap_sync, swap_send, swap_recv,& - & albf,do_send,do_recv - logical, parameter :: usersend=.false. - - complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf -#ifdef HAVE_VOLATILE - volatile :: sndbuf, rcvbuf -#endif - character(len=20) :: name - - info=psb_success_ - name='psi_swap_tran' - call psb_erractionsave(err_act) - ictxt = iictxt - icomm = iicomm - - call psb_info(ictxt,me,np) - if (np == -1) then - info=psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - n=1 - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 - swap_sync = iand(flag,psb_swap_sync_) /= 0 - swap_send = iand(flag,psb_swap_send_) /= 0 - swap_recv = iand(flag,psb_swap_recv_) /= 0 - do_send = swap_mpi .or. swap_sync .or. swap_send - do_recv = swap_mpi .or. swap_sync .or. swap_recv - - totrcv_ = totrcv * n - totsnd_ = totsnd * n - - if (swap_mpi) then - allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& - & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& - & stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - rvhd(:) = mpi_request_null - sdsz(:) = 0 - rvsz(:) = 0 - - ! prepare info for communications - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) - - brvidx(proc_to_comm) = rcv_pt - rvsz(proc_to_comm) = nerv - - bsdidx(proc_to_comm) = snd_pt - sdsz(proc_to_comm) = nesd - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - - end do - - else - allocate(rvhd(totxch),prcid(totxch),stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - end if - - - totrcv_ = max(totrcv_,1) - totsnd_ = max(totsnd_,1) - if((totrcv_+totsnd_) < size(work)) then - sndbuf => work(1:totsnd_) - rcvbuf => work(totsnd_+1:totsnd_+totrcv_) - albf=.false. - else - allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - albf=.true. - end if - - - if (do_send) then - - ! Pack send buffers - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+psb_n_elem_recv_ - - call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& - & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) - - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - ! Case SWAP_MPI - if (swap_mpi) then - - ! swap elements using mpi_alltoallv - call mpi_alltoallv(rcvbuf,rvsz,brvidx,& - & psb_mpi_c_dpk_,& - & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - - else if (swap_sync) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if (proc_to_comm < me) then - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - else if (proc_to_comm > me) then - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send .and. swap_recv) then - - ! First I post all the non blocking receives - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - call psb_get_rank(prcid(i),ictxt,proc_to_comm) - if ((nesd>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - call mpi_irecv(sndbuf(snd_pt),nesd,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag,icomm,rvhd(i),iret) - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - ! Then I post all the blocking sends - if (usersend) call mpi_barrier(icomm,iret) - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - - if ((nerv>0).and.(proc_to_comm /= me)) then - p2ptag = psb_dcomplex_swap_tag - if (usersend) then - call mpi_rsend(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,iret) - else - call mpi_send(rcvbuf(rcv_pt),nerv,& - & psb_mpi_c_dpk_,prcid(i),& - & p2ptag, icomm,iret) - end if - - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - end if - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - - pnti = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - p2ptag = psb_dcomplex_swap_tag - - if ((proc_to_comm /= me).and.(nesd>0)) then - call mpi_wait(rvhd(i),p2pstat,iret) - if(iret /= mpi_success) then - ierr(1) = iret - info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else if (proc_to_comm == me) then - if (nesd /= nerv) then - write(psb_err_unit,*) & - & 'Fatal error in swaptran: mismatch on self send', & - & nerv,nesd - end if - sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) - end if - pnti = pnti + nerv + nesd + 3 - end do - - - else if (swap_send) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nerv>0) call psb_snd(ictxt,& - & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - else if (swap_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - if (nesd>0) call psb_rcv(ictxt,& - & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (do_recv) then - - pnti = 1 - snd_pt = 1 - rcv_pt = 1 - do i=1, totxch - proc_to_comm = idx(pnti+psb_proc_id_) - nerv = idx(pnti+psb_n_elem_recv_) - nesd = idx(pnti+nerv+psb_n_elem_send_) - idx_pt = 1+pnti+nerv+psb_n_elem_send_ - call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& - & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) - rcv_pt = rcv_pt + nerv - snd_pt = snd_pt + nesd - pnti = pnti + nerv + nesd + 3 - end do - - end if - - if (swap_mpi) then - deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& - & stat=info) - else - deallocate(rvhd,prcid,stat=info) - end if - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - if(albf) deallocate(sndbuf,rcvbuf,stat=info) - if(info /= psb_success_) then - call psb_errpush(psb_err_alloc_dealloc_,name) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(iictxt,err_act) - - return -end subroutine psi_ztranidxv -! ! ! Subroutine: psi_zswaptran_vect ! Data exchange among processes. @@ -1046,7 +120,6 @@ subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1132,13 +205,12 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1178,8 +250,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1254,9 +325,8 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if @@ -1271,8 +341,7 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1291,18 +360,16 @@ subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if @@ -1401,7 +468,6 @@ subroutine psi_zswaptran_multivect(flag,beta,y,desc_a,work,info,data) ! locals integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ class(psb_i_base_vect_type), pointer :: d_vidx - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info=psb_success_ @@ -1486,13 +552,12 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv ! locals - integer(psb_mpik_) :: ictxt, icomm, np, me,& + integer(psb_mpk_) :: ictxt, icomm, np, me,& & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret - integer(psb_mpik_), allocatable :: prcid(:) + integer(psb_mpk_), allocatable :: prcid(:) integer(psb_ipk_) :: nesd, nerv,& & err_act, i, idx_pt, totsnd_, totrcv_,& & snd_pt, rcv_pt, pnti, n - integer(psb_ipk_) :: ierr(5) logical :: swap_mpi, swap_sync, swap_send, swap_recv,& & albf,do_send,do_recv logical, parameter :: usersend=.false., debug=.false. @@ -1533,8 +598,7 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! Unfinished communication? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if end if @@ -1608,9 +672,8 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& end if if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if rcv_pt = rcv_pt + n*nerv @@ -1626,8 +689,7 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& ! No matching send? Something is wrong.... ! info=psb_err_mpi_error_ - ierr(1) = -2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/-2/)) goto 9999 end if call psb_realloc(totxch,prcid,info) @@ -1645,18 +707,16 @@ subroutine psi_ztran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& if (nerv>0) then call mpi_wait(y%comid(i,1),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if if (nesd>0) then call mpi_wait(y%comid(i,2),p2pstat,iret) if(iret /= mpi_success) then - ierr(1) = iret info=psb_err_mpi_error_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/iret/)) goto 9999 end if end if diff --git a/base/comm/internals/psi_zswaptran_a.F90 b/base/comm/internals/psi_zswaptran_a.F90 new file mode 100644 index 000000000..7388c3b4a --- /dev/null +++ b/base/comm/internals/psi_zswaptran_a.F90 @@ -0,0 +1,1004 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psi_zswaptran.F90 +! +! Subroutine: psi_zswaptranm +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:,:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_zswaptranm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, err_act, totxch, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if(present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,n,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zswaptranm + +subroutine psi_ztranidxm(iictxt,iicomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ztranidxm + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag,n + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = n*nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = n*nesd + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,n,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+n*nerv-1)) + + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_c_dpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(sndbuf(snd_pt),n*nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),n*nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + p2ptag = psb_dcomplex_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send',& + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+n*nesd-1) = rcvbuf(rcv_pt:rcv_pt+n*nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+n*nerv-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+n*nesd-1), proc_to_comm) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,n,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) + rcv_pt = rcv_pt + n*nerv + snd_pt = snd_pt + n*nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_ztranidxm +! +! +! Subroutine: psi_zswaptranv +! Does the data exchange among processes. This is similar to Xswapdata, but +! the list is read "in reverse", i.e. indices that are normally SENT are used +! for the RECEIVE part and vice-versa. This is the basic data exchange operation +! for doing the product of a sparse matrix by a vector. +! Essentially this is doing a variable all-to-all data exchange +! (ALLTOALLV in MPI parlance), but +! it is capable of pruning empty exchanges, which are very likely in out +! application environment. All the variants have the same structure +! In all these subroutines X may be: I Integer +! S real(psb_spk_) +! D real(psb_dpk_) +! C complex(psb_spk_) +! Z complex(psb_dpk_) +! Basically the operation is as follows: on each process, we identify +! sections SND(Y) and RCV(Y); then we do a SEND(PACK(SND(Y))); +! then we receive, and we do an update with Y = UNPACK(RCV(Y)) + BETA * Y +! but only on the elements involved in the UNPACK operation. +! Thus: for halo data exchange, the receive section is confined in the +! halo indices, and BETA=0, whereas for overlap exchange the receive section +! is scattered in the owned indices, and BETA=1. +! +! Arguments: +! flag - integer Choose the algorithm for data exchange: +! this is chosen through bit fields. +! swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! swap_sync = iand(flag,psb_swap_sync_) /= 0 +! swap_send = iand(flag,psb_swap_send_) /= 0 +! swap_recv = iand(flag,psb_swap_recv_) /= 0 +! if (swap_mpi): use underlying MPI_ALLTOALLV. +! if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +! n - integer Number of columns in Y +! beta - X Choose overwrite or sum. +! y(:) - X The data area +! desc_a - type(psb_desc_type). The communication descriptor. +! work(:) - X Buffer space. If not sufficient, will do +! our own internal allocation. +! info - integer. return code. +! data - integer which list is to be used to exchange data +! default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) + + use psi_mod, psb_protect_name => psi_zswaptranv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_), target :: work(:) + type(psb_desc_type),target :: desc_a + integer(psb_ipk_), optional :: data + + ! locals + integer(psb_ipk_) :: ictxt, np, me, icomm, idxs, idxr, totxch, err_act, data_ + integer(psb_ipk_), pointer :: d_idx(:) + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tranv' + call psb_erractionsave(err_act) + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.psb_is_asb_desc(desc_a)) then + info=psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + end if + + call desc_a%get_list(data_,d_idx,totxch,idxr,idxs,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='psb_cd_get_list') + goto 9999 + end if + + call psi_swaptran(ictxt,icomm,flag,beta,y,d_idx,totxch,idxs,idxr,work,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return +end subroutine psi_zswaptranv + + +! +! +! Subroutine: psi_ztranidxv +! Does the data exchange among processes. +! +! The real workhorse: the outer routines will only choose the index list +! this one takes the index list and does the actual exchange. +! +! +! +subroutine psi_ztranidxv(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + + use psi_mod, psb_protect_name => psi_ztranidxv + use psb_error_mod + use psb_desc_mod + use psb_penv_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_), target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd, totrcv + + ! locals + integer(psb_mpk_) :: ictxt, icomm, np, me,& + & proc_to_comm, p2ptag, p2pstat(mpi_status_size), iret + integer(psb_mpk_), allocatable, dimension(:) :: bsdidx, brvidx,& + & sdsz, rvsz, prcid, rvhd, sdhd + integer(psb_ipk_) :: nesd, nerv,& + & err_act, i, idx_pt, totsnd_, totrcv_,& + & snd_pt, rcv_pt, pnti, n + logical :: swap_mpi, swap_sync, swap_send, swap_recv,& + & albf,do_send,do_recv + logical, parameter :: usersend=.false. + + complex(psb_dpk_), pointer, dimension(:) :: sndbuf, rcvbuf +#ifdef HAVE_VOLATILE + volatile :: sndbuf, rcvbuf +#endif + character(len=20) :: name + + info=psb_success_ + name='psi_swap_tran' + call psb_erractionsave(err_act) + ictxt = iictxt + icomm = iicomm + + call psb_info(ictxt,me,np) + if (np == -1) then + info=psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + n=1 + swap_mpi = iand(flag,psb_swap_mpi_) /= 0 + swap_sync = iand(flag,psb_swap_sync_) /= 0 + swap_send = iand(flag,psb_swap_send_) /= 0 + swap_recv = iand(flag,psb_swap_recv_) /= 0 + do_send = swap_mpi .or. swap_sync .or. swap_send + do_recv = swap_mpi .or. swap_sync .or. swap_recv + + totrcv_ = totrcv * n + totsnd_ = totsnd * n + + if (swap_mpi) then + allocate(sdsz(0:np-1), rvsz(0:np-1), bsdidx(0:np-1),& + & brvidx(0:np-1), rvhd(0:np-1), sdhd(0:np-1), prcid(0:np-1),& + & stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + rvhd(:) = mpi_request_null + sdsz(:) = 0 + rvsz(:) = 0 + + ! prepare info for communications + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(proc_to_comm),ictxt,proc_to_comm) + + brvidx(proc_to_comm) = rcv_pt + rvsz(proc_to_comm) = nerv + + bsdidx(proc_to_comm) = snd_pt + sdsz(proc_to_comm) = nesd + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + + end do + + else + allocate(rvhd(totxch),prcid(totxch),stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + end if + + + totrcv_ = max(totrcv_,1) + totsnd_ = max(totsnd_,1) + if((totrcv_+totsnd_) < size(work)) then + sndbuf => work(1:totsnd_) + rcvbuf => work(totsnd_+1:totsnd_+totrcv_) + albf=.false. + else + allocate(sndbuf(totsnd_),rcvbuf(totrcv_), stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + albf=.true. + end if + + + if (do_send) then + + ! Pack send buffers + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+psb_n_elem_recv_ + + call psi_gth(nerv,idx(idx_pt:idx_pt+nerv-1),& + & y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) + + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + ! Case SWAP_MPI + if (swap_mpi) then + + ! swap elements using mpi_alltoallv + call mpi_alltoallv(rcvbuf,rvsz,brvidx,& + & psb_mpi_c_dpk_,& + & sndbuf,sdsz,bsdidx,psb_mpi_c_dpk_,icomm,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + + else if (swap_sync) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if (proc_to_comm < me) then + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + else if (proc_to_comm > me) then + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send .and. swap_recv) then + + ! First I post all the non blocking receives + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + call psb_get_rank(prcid(i),ictxt,proc_to_comm) + if ((nesd>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + call mpi_irecv(sndbuf(snd_pt),nesd,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag,icomm,rvhd(i),iret) + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + ! Then I post all the blocking sends + if (usersend) call mpi_barrier(icomm,iret) + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + + if ((nerv>0).and.(proc_to_comm /= me)) then + p2ptag = psb_dcomplex_swap_tag + if (usersend) then + call mpi_rsend(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,iret) + else + call mpi_send(rcvbuf(rcv_pt),nerv,& + & psb_mpi_c_dpk_,prcid(i),& + & p2ptag, icomm,iret) + end if + + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + end if + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + + pnti = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + p2ptag = psb_dcomplex_swap_tag + + if ((proc_to_comm /= me).and.(nesd>0)) then + call mpi_wait(rvhd(i),p2pstat,iret) + if(iret /= mpi_success) then + info=psb_err_mpi_error_ + call psb_errpush(info,name,m_err=(/iret/)) + goto 9999 + end if + else if (proc_to_comm == me) then + if (nesd /= nerv) then + write(psb_err_unit,*) & + & 'Fatal error in swaptran: mismatch on self send', & + & nerv,nesd + end if + sndbuf(snd_pt:snd_pt+nesd-1) = rcvbuf(rcv_pt:rcv_pt+nerv-1) + end if + pnti = pnti + nerv + nesd + 3 + end do + + + else if (swap_send) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nerv>0) call psb_snd(ictxt,& + & rcvbuf(rcv_pt:rcv_pt+nerv-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + else if (swap_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + if (nesd>0) call psb_rcv(ictxt,& + & sndbuf(snd_pt:snd_pt+nesd-1), proc_to_comm) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (do_recv) then + + pnti = 1 + snd_pt = 1 + rcv_pt = 1 + do i=1, totxch + proc_to_comm = idx(pnti+psb_proc_id_) + nerv = idx(pnti+psb_n_elem_recv_) + nesd = idx(pnti+nerv+psb_n_elem_send_) + idx_pt = 1+pnti+nerv+psb_n_elem_send_ + call psi_sct(nesd,idx(idx_pt:idx_pt+nesd-1),& + & sndbuf(snd_pt:snd_pt+nesd-1),beta,y) + rcv_pt = rcv_pt + nerv + snd_pt = snd_pt + nesd + pnti = pnti + nerv + nesd + 3 + end do + + end if + + if (swap_mpi) then + deallocate(sdsz,rvsz,bsdidx,brvidx,rvhd,prcid,sdhd,& + & stat=info) + else + deallocate(rvhd,prcid,stat=info) + end if + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + if(albf) deallocate(sndbuf,rcvbuf,stat=info) + if(info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(iictxt,err_act) + + return +end subroutine psi_ztranidxv diff --git a/base/comm/psb_cgather.f90 b/base/comm/psb_cgather.f90 index 98e0c46c2..d4e675c29 100644 --- a/base/comm/psb_cgather.f90 +++ b/base/comm/psb_cgather.f90 @@ -45,291 +45,6 @@ ! global matrix. If -1 all ! the processes will have a copy. ! -subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_cgatherm - implicit none - - complex(psb_spk_), intent(in) :: locx(:,:) - complex(psb_spk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & - & ilx, i, j, idx - - character(len=20) :: name, ch_err - - name='psb_cgatherm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - if (root == -1) then - iiroot = psb_root_ - else - iiroot = root - endif - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - lda_globx = m - lda_locx = size(locx, 1) - lock = size(locx,2) - maxk = lock - k = maxk - - call psb_bcast(ictxt,k,root=iiroot) - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,k,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:,:)=czero - - do j=1,k - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx,j) = locx(i,jlx+j-1) - end do - end do - - do j=1,k - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx,j) = czero - end if - end do - end do - - call psb_sum(ictxt,globx(1:m,1:k),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_cgatherm - - - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_cgatherv -! This subroutine gathers pieces of a distributed dense vector into a local one. -! -! Arguments: -! globx - complex,dimension(:). The local vector into which gather -! the distributed pieces. -! locx - complex,dimension(:). The local piece of the distributed -! vector to be gathered. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Error code. -! iroot - integer. The process that has to own the -! global matrix. If -1 all -! the processes will have a copy. -! default: -1 -! -subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_cgatherv - implicit none - - complex(psb_spk_), intent(in) :: locx(:) - complex(psb_spk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx - - character(len=20) :: name, ch_err - - name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - - jglobx=1 - iglobx = 1 - jlocx=1 - ilocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - lda_globx = m - lda_locx = size(locx) - - k = 1 - - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:)=czero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = czero - end if - end do - - call psb_sum(ictxt,globx(1:m),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_cgatherv - - - subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_cgather_vect implicit none @@ -342,16 +57,18 @@ subroutine psb_cgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_spk_), allocatable :: llocx(:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -455,16 +172,18 @@ subroutine psb_cgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_spk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/comm/psb_cgather_a.f90 b/base/comm/psb_cgather_a.f90 new file mode 100644 index 000000000..09e35678e --- /dev/null +++ b/base/comm/psb_cgather_a.f90 @@ -0,0 +1,335 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cgather.f90 +! +! Subroutine: psb_cgatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - complex,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - complex,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_cgatherm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_cgatherm + implicit none + + complex(psb_spk_), intent(in) :: locx(:,:) + complex(psb_spk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_cgatherm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + if (root == -1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = size(locx, 1) + lock = size(locx,2) + maxk = lock + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=czero + + do j=1,k + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,j) = locx(i,jlx+j-1) + end do + end do + + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,j) = czero + end if + end do + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_cgatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_cgatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - complex,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - complex,dimension(:). The local piece of the distributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! default: -1 +! +subroutine psb_cgatherv(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_cgatherv + implicit none + + complex(psb_spk_), intent(in) :: locx(:) + complex(psb_spk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_cgatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + lda_globx = m + lda_locx = size(locx) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=czero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = czero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_cgatherv + diff --git a/base/comm/psb_chalo.f90 b/base/comm/psb_chalo.f90 index dc92c2fa5..6bd6ce3d6 100644 --- a/base/comm/psb_chalo.f90 +++ b/base/comm/psb_chalo.f90 @@ -52,345 +52,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_chalom - use psi_mod - implicit none - - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_, ldx - complex(psb_spk_),pointer :: iwork(:), xp(:,:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_chalom' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - xp => x(iix:size(x,1),jjx:jjx+k-1) - if(tran_ == 'N') then - call psi_swapdata(imode,k,czero,xp,& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,k,cone,xp,& - &desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_cswapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_chalom - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_chalov -! This subroutine performs the exchange of the halo elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x - real,dimension(:). The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! jx - integer(optional). The starting column of the global matrix. -! ik - integer(optional). The number of columns to gather. -! work - complex(optional). Work area. -! tran - character(optional). Transpose exchange. -! mode - integer(optional). Communication mode (see Swapdata) -! data - integer Which index list in desc_a should be used -! to retrieve rows, default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psb_chalov(x,desc_a,info,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_chalov - use psi_mod - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, ldx, & - & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ - complex(psb_spk_),pointer :: iwork(:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_chalov' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - if(tran_ == 'N') then - call psi_swapdata(imode,czero,x(iix:size(x)),& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,cone,x(iix:size(x)),& - & desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_chalov - subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_chalo_vect @@ -405,18 +66,20 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_chalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -458,7 +121,7 @@ subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -544,18 +207,20 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_chalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -597,7 +262,7 @@ subroutine psb_chalo_multivect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_chalo_a.f90 b/base/comm/psb_chalo_a.f90 new file mode 100644 index 000000000..5deff1b14 --- /dev/null +++ b/base/comm/psb_chalo_a.f90 @@ -0,0 +1,398 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_chalo.f90 +! +! Subroutine: psb_chalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - complex,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - complex(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_chalom + use psi_mod + implicit none + + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx + integer(psb_lpk_) :: m, n, ix, ijx + complex(psb_spk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_chalom' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,czero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,cone,xp,& + &desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_cswapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_chalom + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_chalov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - complex(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_chalov(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_chalov + use psi_mod + implicit none + + complex(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + complex(psb_spk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_chalov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,czero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,cone,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_chalov + diff --git a/base/comm/psb_covrl.f90 b/base/comm/psb_covrl.f90 index 119ab5bf2..ee59ec4df 100644 --- a/base/comm/psb_covrl.f90 +++ b/base/comm/psb_covrl.f90 @@ -63,322 +63,6 @@ ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -! -subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) - use psb_base_mod, psb_protect_name => psb_covrlm - use psi_mod - implicit none - - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork, ldx - complex(psb_spk_),pointer :: iwork(:), xp(:,:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_covrlm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - ! exchange overlap elements - if(do_swap) then - xp => x(iix:ldx,jjx:jjx+k-1) - call psi_swapdata(mode_,k,cone,xp,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_covrlm -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_covrlv -! This subroutine performs the exchange of the overlap elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x(:) - complex The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. -! work - complex(optional). A work area. -! update - integer(optional). Type of update: -! psb_none_ do nothing -! psb_sum_ sum of overlaps -! psb_avg_ average of overlaps -! mode - integer(optional). Choose the algorithm for data exchange: -! this is chosen through bit fields. -! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! - swap_sync = iand(flag,psb_swap_sync_) /= 0 -! - swap_send = iand(flag,psb_swap_send_) /= 0 -! - swap_recv = iand(flag,psb_swap_recv_) /= 0 -! - if (swap_mpi): use underlying MPI_ALLTOALLV. -! - if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! - if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! - if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! - if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -subroutine psb_covrlv(x,desc_a,info,work,update,mode) - use psb_base_mod, psb_protect_name => psb_covrlv - use psi_mod - implicit none - - complex(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - - ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork, ldx - complex(psb_spk_),pointer :: iwork(:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_covrlv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - k = 1 - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - - ! exchange overlap elements - if (do_swap) then - call psi_swapdata(mode_,cone,x,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_covrlv - - subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) use psb_base_mod, psb_protect_name => psb_covrl_vect use psi_mod @@ -391,18 +75,20 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_covrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -443,7 +129,7 @@ subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -516,18 +202,20 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx complex(psb_spk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_covrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -568,7 +256,7 @@ subroutine psb_covrl_multivect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_covrl_a.f90 b/base/comm/psb_covrl_a.f90 new file mode 100644 index 000000000..d5bdc6df2 --- /dev/null +++ b/base/comm/psb_covrl_a.f90 @@ -0,0 +1,384 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_covrl.f90 +! +! Subroutine: psb_covrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - complex The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - complex(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_base_mod, psb_protect_name => psb_covrlm + use psi_mod + implicit none + + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + complex(psb_spk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_covrlm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:ldx,jjx:jjx+k-1) + call psi_swapdata(mode_,k,cone,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_covrlm +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_covrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - complex The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - complex(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_covrlv(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_covrlv + use psi_mod + implicit none + + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + & k, update_, mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + complex(psb_spk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_covrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,cone,x,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_covrlv diff --git a/base/comm/psb_cscatter.F90 b/base/comm/psb_cscatter.F90 index b5f0f24fa..77036d041 100644 --- a/base/comm/psb_cscatter.F90 +++ b/base/comm/psb_cscatter.F90 @@ -43,456 +43,6 @@ ! iroot - integer(optional). The process that owns the global matrix. ! If -1 all the processes have a copy. ! Default -1 -subroutine psb_cscatterm(globx, locx, desc_a, info, root) - - use psb_base_mod, psb_protect_name => psb_cscatterm -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - complex(psb_spk_), intent(out), allocatable :: locx(:,:) - complex(psb_spk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & - & col,pos - complex(psb_spk_),allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - - name='psb_scatterm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot >= np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - iglobx = 1 - jglobx = 1 - lda_globx = size(globx,1) - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,me) - - if (iroot==-1) then - lda_globx = size(globx, 1) - k = size(globx,2) - else - if (iam==iroot) then - k = size(globx,2) - lda_globx = size(globx, 1) - end if - end if - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow=desc_a%get_local_rows() - ! root has to gather size information - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - - call psb_geall(locx,desc_a,info,n=k) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do j=1,k - do i=1, nrow - locx(i,j)=globx(ltg(i),j) - end do - end do - else - - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if (iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1)+all_dim(i-1) - end do - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - do col=1, k - ! prepare vector to scatter - if(iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx,col) - end do - end do - end if - - ! scatter - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_c_spk_,locx(1,col),nrow,& - & psb_mpi_c_spk_,rootrank,icomm,info) - - end do - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - end if - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_cscatterm - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -! Subroutine: psb_cscatterv -! This subroutine scatters a global vector locally owned by one process -! into pieces that are local to alle the processes. -! -! Arguments: -! globx - complex,dimension(:). The global vector to scatter. -! locx - complex,dimension(:). The local piece of the ditributed vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! iroot - integer(optional). The process that owns the global vector. If -1 all -! the processes have a copy. -! -subroutine psb_cscatterv(globx, locx, desc_a, info, root) - use psb_base_mod, psb_protect_name => psb_cscatterv -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - complex(psb_spk_), intent(out), allocatable :: locx(:) - complex(psb_spk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx - complex(psb_spk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - integer(psb_ipk_) :: debug_level, debug_unit - - name='psb_scatterv' - if (psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - ictxt=desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,iam) - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - if ((iroot==-1).or.(iam==iroot))& - & lda_globx = size(globx, 1) - - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - k = 1 - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow = desc_a%get_local_rows() - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - call psb_geall(locx,desc_a,info) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do i=1, nrow - locx(i)=globx(ltg(i)) - end do - else - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if(iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1) + all_dim(i-1) - end do - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & - &' dim',all_dim(1:np), sum(all_dim) - endif - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - ! prepare vector to scatter - if (iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx) - - end do - end do - end if - - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_c_spk_,locx,nrow,& - & psb_mpi_c_spk_,rootrank,icomm,info) - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_cscatterv - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) use psb_base_mod, psb_protect_name => psb_cscatter_vect implicit none @@ -504,7 +54,7 @@ subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_c_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpik_) :: ictxt, np, me, icomm, myrank, rootrank + integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx complex(psb_spk_), allocatable :: vlocx(:) @@ -512,9 +62,11 @@ subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) integer(psb_ipk_) :: debug_level, debug_unit name='psb_scatter_vect' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/comm/psb_cscatter_a.F90 b/base/comm/psb_cscatter_a.F90 new file mode 100644 index 000000000..3d29dd37f --- /dev/null +++ b/base/comm/psb_cscatter_a.F90 @@ -0,0 +1,480 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cscatter.f90 +! +! Subroutine: psb_cscatterm +! This subroutine scatters a global matrix locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - complex,dimension(:,:). The global matrix to scatter. +! locx - complex,dimension(:,:). The local piece of the distributed matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_cscatterm(globx, locx, desc_a, info, root) + + use psb_base_mod, psb_protect_name => psb_cscatterm +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + complex(psb_spk_), intent(out), allocatable :: locx(:,:) + complex(psb_spk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & + & col,pos + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + complex(psb_spk_),allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + + name='psb_scatterm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot >= np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + iglobx = 1 + jglobx = 1 + lda_globx = size(globx,1) + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) + + if (iroot==-1) then + lda_globx = size(globx, 1) + k = size(globx,2) + else + if (iam==iroot) then + k = size(globx,2) + lda_globx = size(globx, 1) + end if + end if + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow=desc_a%get_local_rows() + ! root has to gather size information + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + + call psb_geall(locx,desc_a,info,n=k) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do j=1,k + do i=1, nrow + locx(i,j)=globx(ltg(i),j) + end do + end do + else + + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if (iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1)+all_dim(i-1) + end do + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + do col=1, k + ! prepare vector to scatter + if(iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx,col) + end do + end do + end if + + ! scatter + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_c_spk_,locx(1,col),nrow,& + & psb_mpi_c_spk_,rootrank,icomm,info) + + end do + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_cscatterm + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +! Subroutine: psb_cscatterv +! This subroutine scatters a global vector locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - complex,dimension(:). The global vector to scatter. +! locx - complex,dimension(:). The local piece of the ditributed vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! iroot - integer(optional). The process that owns the global vector. If -1 all +! the processes have a copy. +! +subroutine psb_cscatterv(globx, locx, desc_a, info, root) + use psb_base_mod, psb_protect_name => psb_cscatterv +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + complex(psb_spk_), intent(out), allocatable :: locx(:) + complex(psb_spk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + complex(psb_spk_), allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scatterv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt=desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,iam) + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + if ((iroot==-1).or.(iam==iroot))& + & lda_globx = size(globx, 1) + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + k = 1 + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call psb_geall(locx,desc_a,info) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do i=1, nrow + locx(i)=globx(ltg(i)) + end do + else + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if(iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1) + all_dim(i-1) + end do + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & + &' dim',all_dim(1:np), sum(all_dim) + endif + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + ! prepare vector to scatter + if (iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx) + + end do + end do + end if + + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_c_spk_,locx,nrow,& + & psb_mpi_c_spk_,rootrank,icomm,info) + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_cscatterv + diff --git a/base/comm/psb_cspgather.F90 b/base/comm/psb_cspgather.F90 index 00155a58e..b94010618 100644 --- a/base/comm/psb_cspgather.F90 +++ b/base/comm/psb_cspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_cspgather.f90 subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -51,21 +54,183 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep logical, intent(in), optional :: keepnum,keeploc type(psb_c_coo_sparse_mat) :: loc_coo, glob_coo - integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg - integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + integer(psb_ipk_) :: nrg, ncg, nzg, nzl + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpik_) :: ictxt,np,me - integer(psb_mpik_) :: icomm, minfo, ndx - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit name='psb_gather' - if (psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_realloc(nzl,locia,info) + call psb_realloc(nzl,locja,info) + call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + + if (info == psb_success_) call psb_realloc(nzg,glbia,info) + if (info == psb_success_) call psb_realloc(nzg,glbja,info) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_spk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,& + & glbia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,& + & glbja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + deallocate(locia,locja, stat=info) + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + glob_coo%ia(1:nzg) = glbia(1:nzg) + glob_coo%ja(1:nzg) = glbja(1:nzg) + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + deallocate(glbia,glbja, stat=info) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_csp_allgather + + +subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_cspmat_type), intent(inout) :: loca + type(psb_lcspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_lc_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() icomm = desc_a%get_mpic() call psb_info(ictxt, me, np) @@ -86,10 +251,9 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - allocate(nzbr(np), idisp(np),stat=info) + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) if (info /= psb_success_) then - info=psb_err_alloc_request_ - ierr(1) = 2*np + info=psb_err_alloc_request_; ierr(1) = 3*np call psb_errpush(info,name,i_err=ierr,a_err='integer') goto 9999 end if @@ -106,9 +270,25 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(:) = 0 nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 + ! + ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING + ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo @@ -117,21 +297,168 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep & glob_coo%val,nzbr,idisp,& & psb_mpi_c_spk_,icomm,minfo) if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& & glob_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) + & psb_mpi_lpk_,icomm,minfo) if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& & glob_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) + & psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 - end if - + end if call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lcsp_allgather + +subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_lcspmat_type), intent(inout) :: loca + type(psb_lcspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_lc_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1) = 3*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr + nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_spk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! call glob_coo%set_nzeros(nzg) if (present(dupl)) call glob_coo%set_dupl(dupl) call globa%mv_from(glob_coo) @@ -153,4 +480,4 @@ subroutine psb_csp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep return -end subroutine psb_csp_allgather +end subroutine psb_lclcsp_allgather diff --git a/base/comm/psb_dgather.f90 b/base/comm/psb_dgather.f90 index 1c9614d17..3659b4874 100644 --- a/base/comm/psb_dgather.f90 +++ b/base/comm/psb_dgather.f90 @@ -45,291 +45,6 @@ ! global matrix. If -1 all ! the processes will have a copy. ! -subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_dgatherm - implicit none - - real(psb_dpk_), intent(in) :: locx(:,:) - real(psb_dpk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & - & ilx, i, j, idx - - character(len=20) :: name, ch_err - - name='psb_dgatherm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - if (root == -1) then - iiroot = psb_root_ - else - iiroot = root - endif - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - lda_globx = m - lda_locx = size(locx, 1) - lock = size(locx,2) - maxk = lock - k = maxk - - call psb_bcast(ictxt,k,root=iiroot) - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,k,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:,:)=dzero - - do j=1,k - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx,j) = locx(i,jlx+j-1) - end do - end do - - do j=1,k - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx,j) = dzero - end if - end do - end do - - call psb_sum(ictxt,globx(1:m,1:k),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_dgatherm - - - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_dgatherv -! This subroutine gathers pieces of a distributed dense vector into a local one. -! -! Arguments: -! globx - real,dimension(:). The local vector into which gather -! the distributed pieces. -! locx - real,dimension(:). The local piece of the distributed -! vector to be gathered. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Error code. -! iroot - integer. The process that has to own the -! global matrix. If -1 all -! the processes will have a copy. -! default: -1 -! -subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_dgatherv - implicit none - - real(psb_dpk_), intent(in) :: locx(:) - real(psb_dpk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx - - character(len=20) :: name, ch_err - - name='psb_dgatherv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - - jglobx=1 - iglobx = 1 - jlocx=1 - ilocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - lda_globx = m - lda_locx = size(locx) - - k = 1 - - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:)=dzero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = dzero - end if - end do - - call psb_sum(ictxt,globx(1:m),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_dgatherv - - - subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_dgather_vect implicit none @@ -342,16 +57,18 @@ subroutine psb_dgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_dpk_), allocatable :: llocx(:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -455,16 +172,18 @@ subroutine psb_dgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_dpk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/comm/psb_dgather_a.f90 b/base/comm/psb_dgather_a.f90 new file mode 100644 index 000000000..277eb3d04 --- /dev/null +++ b/base/comm/psb_dgather_a.f90 @@ -0,0 +1,335 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dgather.f90 +! +! Subroutine: psb_dgatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - real,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - real,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_dgatherm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_dgatherm + implicit none + + real(psb_dpk_), intent(in) :: locx(:,:) + real(psb_dpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_dgatherm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + if (root == -1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = size(locx, 1) + lock = size(locx,2) + maxk = lock + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=dzero + + do j=1,k + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,j) = locx(i,jlx+j-1) + end do + end do + + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,j) = dzero + end if + end do + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_dgatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_dgatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - real,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - real,dimension(:). The local piece of the distributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! default: -1 +! +subroutine psb_dgatherv(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_dgatherv + implicit none + + real(psb_dpk_), intent(in) :: locx(:) + real(psb_dpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_dgatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + lda_globx = m + lda_locx = size(locx) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=dzero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = dzero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_dgatherv + diff --git a/base/comm/psb_dhalo.f90 b/base/comm/psb_dhalo.f90 index b48365ad3..005c59b2f 100644 --- a/base/comm/psb_dhalo.f90 +++ b/base/comm/psb_dhalo.f90 @@ -52,345 +52,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_dhalom - use psi_mod - implicit none - - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_, ldx - real(psb_dpk_),pointer :: iwork(:), xp(:,:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_dhalom' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - xp => x(iix:size(x,1),jjx:jjx+k-1) - if(tran_ == 'N') then - call psi_swapdata(imode,k,dzero,xp,& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,k,done,xp,& - &desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_cswapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_dhalom - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_dhalov -! This subroutine performs the exchange of the halo elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x - real,dimension(:). The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! jx - integer(optional). The starting column of the global matrix. -! ik - integer(optional). The number of columns to gather. -! work - real(optional). Work area. -! tran - character(optional). Transpose exchange. -! mode - integer(optional). Communication mode (see Swapdata) -! data - integer Which index list in desc_a should be used -! to retrieve rows, default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_dhalov - use psi_mod - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, ldx, & - & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ - real(psb_dpk_),pointer :: iwork(:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_dhalov' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - if(tran_ == 'N') then - call psi_swapdata(imode,dzero,x(iix:size(x)),& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,done,x(iix:size(x)),& - & desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_dhalov - subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_dhalo_vect @@ -405,18 +66,20 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_dhalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -458,7 +121,7 @@ subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -544,18 +207,20 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_dhalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -597,7 +262,7 @@ subroutine psb_dhalo_multivect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_dhalo_a.f90 b/base/comm/psb_dhalo_a.f90 new file mode 100644 index 000000000..9f7b9ee19 --- /dev/null +++ b/base/comm/psb_dhalo_a.f90 @@ -0,0 +1,398 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dhalo.f90 +! +! Subroutine: psb_dhalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - real,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - real(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_dhalom + use psi_mod + implicit none + + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_dpk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_dhalom' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,dzero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,done,xp,& + &desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_cswapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_dhalom + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_dhalov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - real(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_dhalov + use psi_mod + implicit none + + real(psb_dpk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_dpk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_dhalov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,dzero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,done,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_dhalov + diff --git a/base/comm/psb_dovrl.f90 b/base/comm/psb_dovrl.f90 index 47ca0cea9..07b751565 100644 --- a/base/comm/psb_dovrl.f90 +++ b/base/comm/psb_dovrl.f90 @@ -63,322 +63,6 @@ ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -! -subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) - use psb_base_mod, psb_protect_name => psb_dovrlm - use psi_mod - implicit none - - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork, ldx - real(psb_dpk_),pointer :: iwork(:), xp(:,:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_dovrlm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - ! exchange overlap elements - if(do_swap) then - xp => x(iix:ldx,jjx:jjx+k-1) - call psi_swapdata(mode_,k,done,xp,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_dovrlm -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_dovrlv -! This subroutine performs the exchange of the overlap elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x(:) - real The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. -! work - real(optional). A work area. -! update - integer(optional). Type of update: -! psb_none_ do nothing -! psb_sum_ sum of overlaps -! psb_avg_ average of overlaps -! mode - integer(optional). Choose the algorithm for data exchange: -! this is chosen through bit fields. -! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! - swap_sync = iand(flag,psb_swap_sync_) /= 0 -! - swap_send = iand(flag,psb_swap_send_) /= 0 -! - swap_recv = iand(flag,psb_swap_recv_) /= 0 -! - if (swap_mpi): use underlying MPI_ALLTOALLV. -! - if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! - if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! - if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! - if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -subroutine psb_dovrlv(x,desc_a,info,work,update,mode) - use psb_base_mod, psb_protect_name => psb_dovrlv - use psi_mod - implicit none - - real(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - - ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork, ldx - real(psb_dpk_),pointer :: iwork(:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_dovrlv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - k = 1 - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - - ! exchange overlap elements - if (do_swap) then - call psi_swapdata(mode_,done,x,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_dovrlv - - subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) use psb_base_mod, psb_protect_name => psb_dovrl_vect use psi_mod @@ -391,18 +75,20 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_dovrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -443,7 +129,7 @@ subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -516,18 +202,20 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx real(psb_dpk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_dovrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -568,7 +256,7 @@ subroutine psb_dovrl_multivect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_dovrl_a.f90 b/base/comm/psb_dovrl_a.f90 new file mode 100644 index 000000000..14272ee94 --- /dev/null +++ b/base/comm/psb_dovrl_a.f90 @@ -0,0 +1,384 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_dovrl.f90 +! +! Subroutine: psb_dovrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - real The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_base_mod, psb_protect_name => psb_dovrlm + use psi_mod + implicit none + + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_dpk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_dovrlm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:ldx,jjx:jjx+k-1) + call psi_swapdata(mode_,k,done,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_dovrlm +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_dovrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - real The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_dovrlv(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_dovrlv + use psi_mod + implicit none + + real(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + & k, update_, mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_dpk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_dovrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,done,x,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_dovrlv diff --git a/base/comm/psb_dscatter.F90 b/base/comm/psb_dscatter.F90 index bab52cb96..d559fa129 100644 --- a/base/comm/psb_dscatter.F90 +++ b/base/comm/psb_dscatter.F90 @@ -43,456 +43,6 @@ ! iroot - integer(optional). The process that owns the global matrix. ! If -1 all the processes have a copy. ! Default -1 -subroutine psb_dscatterm(globx, locx, desc_a, info, root) - - use psb_base_mod, psb_protect_name => psb_dscatterm -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - real(psb_dpk_), intent(out), allocatable :: locx(:,:) - real(psb_dpk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & - & col,pos - real(psb_dpk_),allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - - name='psb_scatterm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot >= np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - iglobx = 1 - jglobx = 1 - lda_globx = size(globx,1) - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,me) - - if (iroot==-1) then - lda_globx = size(globx, 1) - k = size(globx,2) - else - if (iam==iroot) then - k = size(globx,2) - lda_globx = size(globx, 1) - end if - end if - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow=desc_a%get_local_rows() - ! root has to gather size information - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - - call psb_geall(locx,desc_a,info,n=k) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do j=1,k - do i=1, nrow - locx(i,j)=globx(ltg(i),j) - end do - end do - else - - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if (iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1)+all_dim(i-1) - end do - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - do col=1, k - ! prepare vector to scatter - if(iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx,col) - end do - end do - end if - - ! scatter - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_r_dpk_,locx(1,col),nrow,& - & psb_mpi_r_dpk_,rootrank,icomm,info) - - end do - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - end if - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_dscatterm - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -! Subroutine: psb_dscatterv -! This subroutine scatters a global vector locally owned by one process -! into pieces that are local to alle the processes. -! -! Arguments: -! globx - real,dimension(:). The global vector to scatter. -! locx - real,dimension(:). The local piece of the ditributed vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! iroot - integer(optional). The process that owns the global vector. If -1 all -! the processes have a copy. -! -subroutine psb_dscatterv(globx, locx, desc_a, info, root) - use psb_base_mod, psb_protect_name => psb_dscatterv -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - real(psb_dpk_), intent(out), allocatable :: locx(:) - real(psb_dpk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx - real(psb_dpk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - integer(psb_ipk_) :: debug_level, debug_unit - - name='psb_scatterv' - if (psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - ictxt=desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,iam) - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - if ((iroot==-1).or.(iam==iroot))& - & lda_globx = size(globx, 1) - - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - k = 1 - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow = desc_a%get_local_rows() - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - call psb_geall(locx,desc_a,info) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do i=1, nrow - locx(i)=globx(ltg(i)) - end do - else - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if(iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1) + all_dim(i-1) - end do - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & - &' dim',all_dim(1:np), sum(all_dim) - endif - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - ! prepare vector to scatter - if (iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx) - - end do - end do - end if - - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_r_dpk_,locx,nrow,& - & psb_mpi_r_dpk_,rootrank,icomm,info) - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_dscatterv - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ subroutine psb_dscatter_vect(globx, locx, desc_a, info, root, mold) use psb_base_mod, psb_protect_name => psb_dscatter_vect implicit none @@ -504,7 +54,7 @@ subroutine psb_dscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_d_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpik_) :: ictxt, np, me, icomm, myrank, rootrank + integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx real(psb_dpk_), allocatable :: vlocx(:) @@ -512,9 +62,11 @@ subroutine psb_dscatter_vect(globx, locx, desc_a, info, root, mold) integer(psb_ipk_) :: debug_level, debug_unit name='psb_scatter_vect' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/comm/psb_dscatter_a.F90 b/base/comm/psb_dscatter_a.F90 new file mode 100644 index 000000000..e8d53a628 --- /dev/null +++ b/base/comm/psb_dscatter_a.F90 @@ -0,0 +1,480 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dscatter.f90 +! +! Subroutine: psb_dscatterm +! This subroutine scatters a global matrix locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - real,dimension(:,:). The global matrix to scatter. +! locx - real,dimension(:,:). The local piece of the distributed matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_dscatterm(globx, locx, desc_a, info, root) + + use psb_base_mod, psb_protect_name => psb_dscatterm +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + real(psb_dpk_), intent(out), allocatable :: locx(:,:) + real(psb_dpk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & + & col,pos + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + real(psb_dpk_),allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + + name='psb_scatterm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot >= np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + iglobx = 1 + jglobx = 1 + lda_globx = size(globx,1) + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) + + if (iroot==-1) then + lda_globx = size(globx, 1) + k = size(globx,2) + else + if (iam==iroot) then + k = size(globx,2) + lda_globx = size(globx, 1) + end if + end if + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow=desc_a%get_local_rows() + ! root has to gather size information + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + + call psb_geall(locx,desc_a,info,n=k) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do j=1,k + do i=1, nrow + locx(i,j)=globx(ltg(i),j) + end do + end do + else + + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if (iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1)+all_dim(i-1) + end do + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + do col=1, k + ! prepare vector to scatter + if(iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx,col) + end do + end do + end if + + ! scatter + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_r_dpk_,locx(1,col),nrow,& + & psb_mpi_r_dpk_,rootrank,icomm,info) + + end do + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_dscatterm + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +! Subroutine: psb_dscatterv +! This subroutine scatters a global vector locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - real,dimension(:). The global vector to scatter. +! locx - real,dimension(:). The local piece of the ditributed vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! iroot - integer(optional). The process that owns the global vector. If -1 all +! the processes have a copy. +! +subroutine psb_dscatterv(globx, locx, desc_a, info, root) + use psb_base_mod, psb_protect_name => psb_dscatterv +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + real(psb_dpk_), intent(out), allocatable :: locx(:) + real(psb_dpk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + real(psb_dpk_), allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scatterv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt=desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,iam) + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + if ((iroot==-1).or.(iam==iroot))& + & lda_globx = size(globx, 1) + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + k = 1 + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call psb_geall(locx,desc_a,info) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do i=1, nrow + locx(i)=globx(ltg(i)) + end do + else + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if(iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1) + all_dim(i-1) + end do + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & + &' dim',all_dim(1:np), sum(all_dim) + endif + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + ! prepare vector to scatter + if (iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx) + + end do + end do + end if + + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_r_dpk_,locx,nrow,& + & psb_mpi_r_dpk_,rootrank,icomm,info) + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_dscatterv + diff --git a/base/comm/psb_dspgather.F90 b/base/comm/psb_dspgather.F90 index 0d373fdf8..d55935042 100644 --- a/base/comm/psb_dspgather.F90 +++ b/base/comm/psb_dspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_dspgather.f90 subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -51,21 +54,183 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep logical, intent(in), optional :: keepnum,keeploc type(psb_d_coo_sparse_mat) :: loc_coo, glob_coo - integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg - integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + integer(psb_ipk_) :: nrg, ncg, nzg, nzl + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpik_) :: ictxt,np,me - integer(psb_mpik_) :: icomm, minfo, ndx - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit name='psb_gather' - if (psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_realloc(nzl,locia,info) + call psb_realloc(nzl,locja,info) + call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + + if (info == psb_success_) call psb_realloc(nzg,glbia,info) + if (info == psb_success_) call psb_realloc(nzg,glbja,info) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_dpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,& + & glbia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,& + & glbja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + deallocate(locia,locja, stat=info) + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + glob_coo%ia(1:nzg) = glbia(1:nzg) + glob_coo%ja(1:nzg) = glbja(1:nzg) + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + deallocate(glbia,glbja, stat=info) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_dsp_allgather + + +subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_dspmat_type), intent(inout) :: loca + type(psb_ldspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_ld_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() icomm = desc_a%get_mpic() call psb_info(ictxt, me, np) @@ -86,10 +251,9 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - allocate(nzbr(np), idisp(np),stat=info) + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) if (info /= psb_success_) then - info=psb_err_alloc_request_ - ierr(1) = 2*np + info=psb_err_alloc_request_; ierr(1) = 3*np call psb_errpush(info,name,i_err=ierr,a_err='integer') goto 9999 end if @@ -106,9 +270,25 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(:) = 0 nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 + ! + ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING + ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo @@ -117,21 +297,168 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep & glob_coo%val,nzbr,idisp,& & psb_mpi_r_dpk_,icomm,minfo) if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& & glob_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) + & psb_mpi_lpk_,icomm,minfo) if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& & glob_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) + & psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 - end if - + end if call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_ldsp_allgather + +subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ldspmat_type), intent(inout) :: loca + type(psb_ldspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_ld_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1) = 3*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr + nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_dpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! call glob_coo%set_nzeros(nzg) if (present(dupl)) call glob_coo%set_dupl(dupl) call globa%mv_from(glob_coo) @@ -153,4 +480,4 @@ subroutine psb_dsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep return -end subroutine psb_dsp_allgather +end subroutine psb_ldldsp_allgather diff --git a/base/comm/psb_egather_a.f90 b/base/comm/psb_egather_a.f90 new file mode 100644 index 000000000..54b77bc98 --- /dev/null +++ b/base/comm/psb_egather_a.f90 @@ -0,0 +1,335 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_egather.f90 +! +! Subroutine: psb_egatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - integer,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - integer,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_egatherm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_egatherm + implicit none + + integer(psb_epk_), intent(in) :: locx(:,:) + integer(psb_epk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_egatherm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + if (root == -1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = size(locx, 1) + lock = size(locx,2) + maxk = lock + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=ezero + + do j=1,k + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,j) = locx(i,jlx+j-1) + end do + end do + + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,j) = ezero + end if + end do + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_egatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_egatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - integer,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - integer,dimension(:). The local piece of the distributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! default: -1 +! +subroutine psb_egatherv(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_egatherv + implicit none + + integer(psb_epk_), intent(in) :: locx(:) + integer(psb_epk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_egatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + lda_globx = m + lda_locx = size(locx) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=ezero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = ezero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_egatherv + diff --git a/base/comm/psb_ehalo_a.f90 b/base/comm/psb_ehalo_a.f90 new file mode 100644 index 000000000..6aa31a0b0 --- /dev/null +++ b/base/comm/psb_ehalo_a.f90 @@ -0,0 +1,398 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_ehalo.f90 +! +! Subroutine: psb_ehalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - integer,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_ehalom + use psi_mod + implicit none + + integer(psb_epk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_epk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_ehalom' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,ezero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,eone,xp,& + &desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_cswapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_ehalom + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_ehalov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_ehalov + use psi_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_epk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_ehalov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,ezero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,eone,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_ehalov + diff --git a/base/comm/psb_eovrl_a.f90 b/base/comm/psb_eovrl_a.f90 new file mode 100644 index 000000000..282c0b33e --- /dev/null +++ b/base/comm/psb_eovrl_a.f90 @@ -0,0 +1,384 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_eovrl.f90 +! +! Subroutine: psb_eovrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - integer The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_base_mod, psb_protect_name => psb_eovrlm + use psi_mod + implicit none + + integer(psb_epk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_epk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_eovrlm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:ldx,jjx:jjx+k-1) + call psi_swapdata(mode_,k,eone,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_eovrlm +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_eovrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - integer The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - integer(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_eovrlv(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_eovrlv + use psi_mod + implicit none + + integer(psb_epk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + & k, update_, mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_epk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_eovrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,eone,x,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_eovrlv diff --git a/base/comm/psb_escatter_a.F90 b/base/comm/psb_escatter_a.F90 new file mode 100644 index 000000000..62bc5734f --- /dev/null +++ b/base/comm/psb_escatter_a.F90 @@ -0,0 +1,480 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_escatter.f90 +! +! Subroutine: psb_escatterm +! This subroutine scatters a global matrix locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - integer,dimension(:,:). The global matrix to scatter. +! locx - integer,dimension(:,:). The local piece of the distributed matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_escatterm(globx, locx, desc_a, info, root) + + use psb_base_mod, psb_protect_name => psb_escatterm +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_epk_), intent(out), allocatable :: locx(:,:) + integer(psb_epk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & + & col,pos + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + integer(psb_epk_),allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + + name='psb_scatterm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot >= np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + iglobx = 1 + jglobx = 1 + lda_globx = size(globx,1) + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) + + if (iroot==-1) then + lda_globx = size(globx, 1) + k = size(globx,2) + else + if (iam==iroot) then + k = size(globx,2) + lda_globx = size(globx, 1) + end if + end if + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow=desc_a%get_local_rows() + ! root has to gather size information + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + + call psb_geall(locx,desc_a,info,n=k) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do j=1,k + do i=1, nrow + locx(i,j)=globx(ltg(i),j) + end do + end do + else + + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if (iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1)+all_dim(i-1) + end do + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + do col=1, k + ! prepare vector to scatter + if(iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx,col) + end do + end do + end if + + ! scatter + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_epk_,locx(1,col),nrow,& + & psb_mpi_epk_,rootrank,icomm,info) + + end do + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_escatterm + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +! Subroutine: psb_escatterv +! This subroutine scatters a global vector locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - integer,dimension(:). The global vector to scatter. +! locx - integer,dimension(:). The local piece of the ditributed vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! iroot - integer(optional). The process that owns the global vector. If -1 all +! the processes have a copy. +! +subroutine psb_escatterv(globx, locx, desc_a, info, root) + use psb_base_mod, psb_protect_name => psb_escatterv +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_epk_), intent(out), allocatable :: locx(:) + integer(psb_epk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + integer(psb_epk_), allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scatterv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt=desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,iam) + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + if ((iroot==-1).or.(iam==iroot))& + & lda_globx = size(globx, 1) + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + k = 1 + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call psb_geall(locx,desc_a,info) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do i=1, nrow + locx(i)=globx(ltg(i)) + end do + else + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if(iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1) + all_dim(i-1) + end do + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & + &' dim',all_dim(1:np), sum(all_dim) + endif + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + ! prepare vector to scatter + if (iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx) + + end do + end do + end if + + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_epk_,locx,nrow,& + & psb_mpi_epk_,rootrank,icomm,info) + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_escatterv + diff --git a/base/comm/psb_igather.f90 b/base/comm/psb_igather.f90 index b0ef43708..a6e59497f 100644 --- a/base/comm/psb_igather.f90 +++ b/base/comm/psb_igather.f90 @@ -45,291 +45,6 @@ ! global matrix. If -1 all ! the processes will have a copy. ! -subroutine psb_igatherm(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_igatherm - implicit none - - integer(psb_ipk_), intent(in) :: locx(:,:) - integer(psb_ipk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & - & ilx, i, j, idx - - character(len=20) :: name, ch_err - - name='psb_igatherm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - if (root == -1) then - iiroot = psb_root_ - else - iiroot = root - endif - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - lda_globx = m - lda_locx = size(locx, 1) - lock = size(locx,2) - maxk = lock - k = maxk - - call psb_bcast(ictxt,k,root=iiroot) - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,k,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:,:)=izero - - do j=1,k - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx,j) = locx(i,jlx+j-1) - end do - end do - - do j=1,k - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx,j) = izero - end if - end do - end do - - call psb_sum(ictxt,globx(1:m,1:k),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_igatherm - - - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_igatherv -! This subroutine gathers pieces of a distributed dense vector into a local one. -! -! Arguments: -! globx - integer,dimension(:). The local vector into which gather -! the distributed pieces. -! locx - integer,dimension(:). The local piece of the distributed -! vector to be gathered. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Error code. -! iroot - integer. The process that has to own the -! global matrix. If -1 all -! the processes will have a copy. -! default: -1 -! -subroutine psb_igatherv(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_igatherv - implicit none - - integer(psb_ipk_), intent(in) :: locx(:) - integer(psb_ipk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx - - character(len=20) :: name, ch_err - - name='psb_igatherv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - - jglobx=1 - iglobx = 1 - jlocx=1 - ilocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - lda_globx = m - lda_locx = size(locx) - - k = 1 - - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:)=izero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = izero - end if - end do - - call psb_sum(ictxt,globx(1:m),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_igatherv - - - subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_igather_vect implicit none @@ -342,16 +57,18 @@ subroutine psb_igather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx integer(psb_ipk_), allocatable :: llocx(:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -455,16 +172,18 @@ subroutine psb_igather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx integer(psb_ipk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/comm/psb_ihalo.f90 b/base/comm/psb_ihalo.f90 index e38800294..ab1141ea1 100644 --- a/base/comm/psb_ihalo.f90 +++ b/base/comm/psb_ihalo.f90 @@ -52,345 +52,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_ihalom(x,desc_a,info,jx,ik,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_ihalom - use psi_mod - implicit none - - integer(psb_ipk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_, ldx - integer(psb_ipk_),pointer :: iwork(:), xp(:,:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_ihalom' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - xp => x(iix:size(x,1),jjx:jjx+k-1) - if(tran_ == 'N') then - call psi_swapdata(imode,k,izero,xp,& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,k,ione,xp,& - &desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_cswapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_ihalom - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_ihalov -! This subroutine performs the exchange of the halo elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x - real,dimension(:). The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! jx - integer(optional). The starting column of the global matrix. -! ik - integer(optional). The number of columns to gather. -! work - integer(optional). Work area. -! tran - character(optional). Transpose exchange. -! mode - integer(optional). Communication mode (see Swapdata) -! data - integer Which index list in desc_a should be used -! to retrieve rows, default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psb_ihalov(x,desc_a,info,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_ihalov - use psi_mod - implicit none - - integer(psb_ipk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, ldx, & - & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ - integer(psb_ipk_),pointer :: iwork(:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_ihalov' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - if(tran_ == 'N') then - call psi_swapdata(imode,izero,x(iix:size(x)),& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,ione,x(iix:size(x)),& - & desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_ihalov - subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_ihalo_vect @@ -405,18 +66,20 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx integer(psb_ipk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_ihalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -458,7 +121,7 @@ subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -544,18 +207,20 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx integer(psb_ipk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_ihalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -597,7 +262,7 @@ subroutine psb_ihalo_multivect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_iovrl.f90 b/base/comm/psb_iovrl.f90 index d3a73c2ac..385d5c24a 100644 --- a/base/comm/psb_iovrl.f90 +++ b/base/comm/psb_iovrl.f90 @@ -63,322 +63,6 @@ ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -! -subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) - use psb_base_mod, psb_protect_name => psb_iovrlm - use psi_mod - implicit none - - integer(psb_ipk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork, ldx - integer(psb_ipk_),pointer :: iwork(:), xp(:,:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_iovrlm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - ! exchange overlap elements - if(do_swap) then - xp => x(iix:ldx,jjx:jjx+k-1) - call psi_swapdata(mode_,k,ione,xp,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_iovrlm -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_iovrlv -! This subroutine performs the exchange of the overlap elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x(:) - integer The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. -! work - integer(optional). A work area. -! update - integer(optional). Type of update: -! psb_none_ do nothing -! psb_sum_ sum of overlaps -! psb_avg_ average of overlaps -! mode - integer(optional). Choose the algorithm for data exchange: -! this is chosen through bit fields. -! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! - swap_sync = iand(flag,psb_swap_sync_) /= 0 -! - swap_send = iand(flag,psb_swap_send_) /= 0 -! - swap_recv = iand(flag,psb_swap_recv_) /= 0 -! - if (swap_mpi): use underlying MPI_ALLTOALLV. -! - if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! - if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! - if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! - if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -subroutine psb_iovrlv(x,desc_a,info,work,update,mode) - use psb_base_mod, psb_protect_name => psb_iovrlv - use psi_mod - implicit none - - integer(psb_ipk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - - ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork, ldx - integer(psb_ipk_),pointer :: iwork(:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_iovrlv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - k = 1 - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - - ! exchange overlap elements - if (do_swap) then - call psi_swapdata(mode_,ione,x,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_iovrlv - - subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) use psb_base_mod, psb_protect_name => psb_iovrl_vect use psi_mod @@ -391,18 +75,20 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx integer(psb_ipk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_iovrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -443,7 +129,7 @@ subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -516,18 +202,20 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx integer(psb_ipk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_iovrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -568,7 +256,7 @@ subroutine psb_iovrl_multivect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_iscatter.F90 b/base/comm/psb_iscatter.F90 index e4ab88a12..1a545e9b2 100644 --- a/base/comm/psb_iscatter.F90 +++ b/base/comm/psb_iscatter.F90 @@ -43,456 +43,6 @@ ! iroot - integer(optional). The process that owns the global matrix. ! If -1 all the processes have a copy. ! Default -1 -subroutine psb_iscatterm(globx, locx, desc_a, info, root) - - use psb_base_mod, psb_protect_name => psb_iscatterm -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(out), allocatable :: locx(:,:) - integer(psb_ipk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & - & col,pos - integer(psb_ipk_),allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - - name='psb_scatterm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot >= np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - iglobx = 1 - jglobx = 1 - lda_globx = size(globx,1) - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,me) - - if (iroot==-1) then - lda_globx = size(globx, 1) - k = size(globx,2) - else - if (iam==iroot) then - k = size(globx,2) - lda_globx = size(globx, 1) - end if - end if - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow=desc_a%get_local_rows() - ! root has to gather size information - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - - call psb_geall(locx,desc_a,info,n=k) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do j=1,k - do i=1, nrow - locx(i,j)=globx(ltg(i),j) - end do - end do - else - - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if (iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1)+all_dim(i-1) - end do - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - do col=1, k - ! prepare vector to scatter - if(iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx,col) - end do - end do - end if - - ! scatter - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_ipk_integer,locx(1,col),nrow,& - & psb_mpi_ipk_integer,rootrank,icomm,info) - - end do - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - end if - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_iscatterm - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -! Subroutine: psb_iscatterv -! This subroutine scatters a global vector locally owned by one process -! into pieces that are local to alle the processes. -! -! Arguments: -! globx - integer,dimension(:). The global vector to scatter. -! locx - integer,dimension(:). The local piece of the ditributed vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! iroot - integer(optional). The process that owns the global vector. If -1 all -! the processes have a copy. -! -subroutine psb_iscatterv(globx, locx, desc_a, info, root) - use psb_base_mod, psb_protect_name => psb_iscatterv -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - integer(psb_ipk_), intent(out), allocatable :: locx(:) - integer(psb_ipk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx - integer(psb_ipk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - integer(psb_ipk_) :: debug_level, debug_unit - - name='psb_scatterv' - if (psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - ictxt=desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,iam) - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - if ((iroot==-1).or.(iam==iroot))& - & lda_globx = size(globx, 1) - - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - k = 1 - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow = desc_a%get_local_rows() - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - call psb_geall(locx,desc_a,info) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do i=1, nrow - locx(i)=globx(ltg(i)) - end do - else - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if(iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1) + all_dim(i-1) - end do - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & - &' dim',all_dim(1:np), sum(all_dim) - endif - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - ! prepare vector to scatter - if (iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx) - - end do - end do - end if - - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_ipk_integer,locx,nrow,& - & psb_mpi_ipk_integer,rootrank,icomm,info) - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_iscatterv - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ subroutine psb_iscatter_vect(globx, locx, desc_a, info, root, mold) use psb_base_mod, psb_protect_name => psb_iscatter_vect implicit none @@ -504,7 +54,7 @@ subroutine psb_iscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_i_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpik_) :: ictxt, np, me, icomm, myrank, rootrank + integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx integer(psb_ipk_), allocatable :: vlocx(:) @@ -512,9 +62,11 @@ subroutine psb_iscatter_vect(globx, locx, desc_a, info, root, mold) integer(psb_ipk_) :: debug_level, debug_unit name='psb_scatter_vect' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/comm/psb_ispgather.F90 b/base/comm/psb_ispgather.F90 new file mode 100644 index 000000000..a19d24d9e --- /dev/null +++ b/base/comm/psb_ispgather.F90 @@ -0,0 +1,483 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_ispgather.f90 +subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ispmat_type), intent(inout) :: loca + type(psb_ispmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_i_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_ipk_) :: nrg, ncg, nzg, nzl + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_realloc(nzl,locia,info) + call psb_realloc(nzl,locja,info) + call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + + if (info == psb_success_) call psb_realloc(nzg,glbia,info) + if (info == psb_success_) call psb_realloc(nzg,glbja,info) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_ipk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,& + & glbia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,& + & glbja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + deallocate(locia,locja, stat=info) + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + glob_coo%ia(1:nzg) = glbia(1:nzg) + glob_coo%ja(1:nzg) = glbja(1:nzg) + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + deallocate(glbia,glbja, stat=info) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_isp_allgather + + +subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_ispmat_type), intent(inout) :: loca + type(psb_@LX@spmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_@LX@_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1) = 3*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr + nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + ! + ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING + ! + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_ipk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_@LX@sp_allgather + +subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_@LX@spmat_type), intent(inout) :: loca + type(psb_@LX@spmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_@LX@_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1) = 3*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr + nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_ipk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_ipk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_@LX@@LX@sp_allgather diff --git a/base/comm/psb_lgather.f90 b/base/comm/psb_lgather.f90 new file mode 100644 index 000000000..45ea0d945 --- /dev/null +++ b/base/comm/psb_lgather.f90 @@ -0,0 +1,274 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_lgather.f90 +! +! Subroutine: psb_lgatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - integer,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - integer,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_lgather_vect(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_lgather_vect + implicit none + + type(psb_l_vect_type), intent(inout) :: locx + integer(psb_lpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx + integer(psb_lpk_), allocatable :: llocx(:) + character(len=20) :: name, ch_err + + name='psb_cgatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = locx%get_nrows() + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:) = lzero + llocx = locx%get_vect() + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = llocx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = lzero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lgather_vect + + +subroutine psb_lgather_multivect(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_lgather_multivect + implicit none + + type(psb_l_multivect_type), intent(inout) :: locx + integer(psb_lpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx + integer(psb_lpk_), allocatable :: llocx(:,:) + character(len=20) :: name, ch_err + + name='psb_cgatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = locx%get_nrows() + k = locx%get_ncols() + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,locx%get_nrows(),ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:) = lzero + llocx = locx%get_vect() + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,:) = llocx(i,:) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,:) = lzero + end if + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lgather_multivect diff --git a/base/comm/psb_lhalo.f90 b/base/comm/psb_lhalo.f90 new file mode 100644 index 000000000..36e95b349 --- /dev/null +++ b/base/comm/psb_lhalo.f90 @@ -0,0 +1,336 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_lhalo.f90 +! +! Subroutine: psb_lhalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - integer,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! + +subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_lhalo_vect + use psi_mod + implicit none + + type(psb_l_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_lpk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_lhalov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,lzero,x%v,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,lone,x%v,& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if (info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_lhalo_vect + + +subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_lhalo_multivect + use psi_mod + implicit none + + type(psb_l_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_lpk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_lhalov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + iwork => work + aliw=.false. + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,lzero,x%v,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,lone,x%v,& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if (info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_lhalo_multivect + diff --git a/base/comm/psb_lovrl.f90 b/base/comm/psb_lovrl.f90 new file mode 100644 index 000000000..52fe7f699 --- /dev/null +++ b/base/comm/psb_lovrl.f90 @@ -0,0 +1,318 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_lovrl.f90 +! +! Subroutine: psb_lovrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - integer The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_lovrl_vect + use psi_mod + implicit none + + type(psb_l_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_lpk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_lovrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,lone,x%v,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_lovrl_vect + + +subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_lovrl_multivect + use psi_mod + implicit none + + type(psb_l_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_lpk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_lovrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,lone,x%v,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x%v,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_lovrl_multivect + diff --git a/base/comm/psb_lscatter.F90 b/base/comm/psb_lscatter.F90 new file mode 100644 index 000000000..ed4051faf --- /dev/null +++ b/base/comm/psb_lscatter.F90 @@ -0,0 +1,99 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_lscatter.f90 +! +! Subroutine: psb_lscatterm +! This subroutine scatters a global matrix locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - integer,dimension(:,:). The global matrix to scatter. +! locx - integer,dimension(:,:). The local piece of the distributed matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_lscatter_vect(globx, locx, desc_a, info, root, mold) + use psb_base_mod, psb_protect_name => psb_lscatter_vect + implicit none + type(psb_l_vect_type), intent(inout) :: locx + integer(psb_lpk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + class(psb_l_base_vect_type), intent(in), optional :: mold + + ! locals + integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx + integer(psb_lpk_), allocatable :: vlocx(:) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scatter_vect' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt=desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (info == psb_success_) call psb_scatter(globx, vlocx, desc_a, info, root=root) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_scatterv') + goto 9999 + endif + + call locx%bld(vlocx,mold=mold) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lscatter_vect diff --git a/base/comm/psb_lspgather.F90 b/base/comm/psb_lspgather.F90 new file mode 100644 index 000000000..81c9c67c8 --- /dev/null +++ b/base/comm/psb_lspgather.F90 @@ -0,0 +1,483 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_lspgather.f90 +subroutine psb_lsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_lspmat_type), intent(inout) :: loca + type(psb_lspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_l_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_ipk_) :: nrg, ncg, nzg, nzl + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_realloc(nzl,locia,info) + call psb_realloc(nzl,locja,info) + call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + + if (info == psb_success_) call psb_realloc(nzg,glbia,info) + if (info == psb_success_) call psb_realloc(nzg,glbja,info) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,& + & glbia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,& + & glbja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + deallocate(locia,locja, stat=info) + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + glob_coo%ia(1:nzg) = glbia(1:nzg) + glob_coo%ja(1:nzg) = glbja(1:nzg) + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + deallocate(glbia,glbja, stat=info) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lsp_allgather + + +subroutine psb_@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_lspmat_type), intent(inout) :: loca + type(psb_@LX@spmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_@LX@_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1) = 3*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr + nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + ! + ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING + ! + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_@LX@sp_allgather + +subroutine psb_@LX@@LX@sp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_@LX@spmat_type), intent(inout) :: loca + type(psb_@LX@spmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_@LX@_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1) = 3*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr + nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_lpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_@LX@@LX@sp_allgather diff --git a/base/comm/psb_mgather_a.f90 b/base/comm/psb_mgather_a.f90 new file mode 100644 index 000000000..1ee8e7f4f --- /dev/null +++ b/base/comm/psb_mgather_a.f90 @@ -0,0 +1,335 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_mgather.f90 +! +! Subroutine: psb_mgatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - integer,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - integer,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_mgatherm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_mgatherm + implicit none + + integer(psb_mpk_), intent(in) :: locx(:,:) + integer(psb_mpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_mgatherm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + if (root == -1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = size(locx, 1) + lock = size(locx,2) + maxk = lock + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=mzero + + do j=1,k + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,j) = locx(i,jlx+j-1) + end do + end do + + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,j) = mzero + end if + end do + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_mgatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_mgatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - integer,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - integer,dimension(:). The local piece of the distributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! default: -1 +! +subroutine psb_mgatherv(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_mgatherv + implicit none + + integer(psb_mpk_), intent(in) :: locx(:) + integer(psb_mpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_mgatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + lda_globx = m + lda_locx = size(locx) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=mzero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = mzero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_mgatherv + diff --git a/base/comm/psb_mhalo_a.f90 b/base/comm/psb_mhalo_a.f90 new file mode 100644 index 000000000..092d4bd54 --- /dev/null +++ b/base/comm/psb_mhalo_a.f90 @@ -0,0 +1,398 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_mhalo.f90 +! +! Subroutine: psb_mhalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - integer,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_mhalom(x,desc_a,info,jx,ik,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_mhalom + use psi_mod + implicit none + + integer(psb_mpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_mpk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_mhalom' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,mzero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,mone,xp,& + &desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_cswapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_mhalom + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_mhalov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_mhalov + use psi_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_mpk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_mhalov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,mzero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,mone,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_mhalov + diff --git a/base/comm/psb_movrl_a.f90 b/base/comm/psb_movrl_a.f90 new file mode 100644 index 000000000..2b1b80542 --- /dev/null +++ b/base/comm/psb_movrl_a.f90 @@ -0,0 +1,384 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_movrl.f90 +! +! Subroutine: psb_movrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - integer The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - integer(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_base_mod, psb_protect_name => psb_movrlm + use psi_mod + implicit none + + integer(psb_mpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_mpk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_movrlm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:ldx,jjx:jjx+k-1) + call psi_swapdata(mode_,k,mone,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_movrlm +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_movrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - integer The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - integer(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_movrlv(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_movrlv + use psi_mod + implicit none + + integer(psb_mpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + & k, update_, mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + integer(psb_mpk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_movrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,mone,x,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_movrlv diff --git a/base/comm/psb_mscatter_a.F90 b/base/comm/psb_mscatter_a.F90 new file mode 100644 index 000000000..4778c63f8 --- /dev/null +++ b/base/comm/psb_mscatter_a.F90 @@ -0,0 +1,480 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_mscatter.f90 +! +! Subroutine: psb_mscatterm +! This subroutine scatters a global matrix locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - integer,dimension(:,:). The global matrix to scatter. +! locx - integer,dimension(:,:). The local piece of the distributed matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_mscatterm(globx, locx, desc_a, info, root) + + use psb_base_mod, psb_protect_name => psb_mscatterm +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_mpk_), intent(out), allocatable :: locx(:,:) + integer(psb_mpk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & + & col,pos + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + integer(psb_mpk_),allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + + name='psb_scatterm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot >= np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + iglobx = 1 + jglobx = 1 + lda_globx = size(globx,1) + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) + + if (iroot==-1) then + lda_globx = size(globx, 1) + k = size(globx,2) + else + if (iam==iroot) then + k = size(globx,2) + lda_globx = size(globx, 1) + end if + end if + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow=desc_a%get_local_rows() + ! root has to gather size information + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + + call psb_geall(locx,desc_a,info,n=k) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do j=1,k + do i=1, nrow + locx(i,j)=globx(ltg(i),j) + end do + end do + else + + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if (iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1)+all_dim(i-1) + end do + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + do col=1, k + ! prepare vector to scatter + if(iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx,col) + end do + end do + end if + + ! scatter + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_mpk_,locx(1,col),nrow,& + & psb_mpi_mpk_,rootrank,icomm,info) + + end do + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_mscatterm + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +! Subroutine: psb_mscatterv +! This subroutine scatters a global vector locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - integer,dimension(:). The global vector to scatter. +! locx - integer,dimension(:). The local piece of the ditributed vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! iroot - integer(optional). The process that owns the global vector. If -1 all +! the processes have a copy. +! +subroutine psb_mscatterv(globx, locx, desc_a, info, root) + use psb_base_mod, psb_protect_name => psb_mscatterv +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + integer(psb_mpk_), intent(out), allocatable :: locx(:) + integer(psb_mpk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + integer(psb_mpk_), allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scatterv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt=desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,iam) + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + if ((iroot==-1).or.(iam==iroot))& + & lda_globx = size(globx, 1) + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + k = 1 + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call psb_geall(locx,desc_a,info) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do i=1, nrow + locx(i)=globx(ltg(i)) + end do + else + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if(iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1) + all_dim(i-1) + end do + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & + &' dim',all_dim(1:np), sum(all_dim) + endif + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + ! prepare vector to scatter + if (iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx) + + end do + end do + end if + + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_mpk_,locx,nrow,& + & psb_mpi_mpk_,rootrank,icomm,info) + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_mscatterv + diff --git a/base/comm/psb_sgather.f90 b/base/comm/psb_sgather.f90 index 067856b4e..10c6b7c2c 100644 --- a/base/comm/psb_sgather.f90 +++ b/base/comm/psb_sgather.f90 @@ -45,291 +45,6 @@ ! global matrix. If -1 all ! the processes will have a copy. ! -subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_sgatherm - implicit none - - real(psb_spk_), intent(in) :: locx(:,:) - real(psb_spk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & - & ilx, i, j, idx - - character(len=20) :: name, ch_err - - name='psb_sgatherm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - if (root == -1) then - iiroot = psb_root_ - else - iiroot = root - endif - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - lda_globx = m - lda_locx = size(locx, 1) - lock = size(locx,2) - maxk = lock - k = maxk - - call psb_bcast(ictxt,k,root=iiroot) - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,k,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:,:)=szero - - do j=1,k - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx,j) = locx(i,jlx+j-1) - end do - end do - - do j=1,k - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx,j) = szero - end if - end do - end do - - call psb_sum(ictxt,globx(1:m,1:k),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_sgatherm - - - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_sgatherv -! This subroutine gathers pieces of a distributed dense vector into a local one. -! -! Arguments: -! globx - real,dimension(:). The local vector into which gather -! the distributed pieces. -! locx - real,dimension(:). The local piece of the distributed -! vector to be gathered. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Error code. -! iroot - integer. The process that has to own the -! global matrix. If -1 all -! the processes will have a copy. -! default: -1 -! -subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_sgatherv - implicit none - - real(psb_spk_), intent(in) :: locx(:) - real(psb_spk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx - - character(len=20) :: name, ch_err - - name='psb_sgatherv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - - jglobx=1 - iglobx = 1 - jlocx=1 - ilocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - lda_globx = m - lda_locx = size(locx) - - k = 1 - - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:)=szero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = szero - end if - end do - - call psb_sum(ictxt,globx(1:m),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_sgatherv - - - subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_sgather_vect implicit none @@ -342,16 +57,18 @@ subroutine psb_sgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_spk_), allocatable :: llocx(:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -455,16 +172,18 @@ subroutine psb_sgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx real(psb_spk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/comm/psb_sgather_a.f90 b/base/comm/psb_sgather_a.f90 new file mode 100644 index 000000000..68076959a --- /dev/null +++ b/base/comm/psb_sgather_a.f90 @@ -0,0 +1,335 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_sgather.f90 +! +! Subroutine: psb_sgatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - real,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - real,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_sgatherm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_sgatherm + implicit none + + real(psb_spk_), intent(in) :: locx(:,:) + real(psb_spk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_sgatherm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + if (root == -1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = size(locx, 1) + lock = size(locx,2) + maxk = lock + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=szero + + do j=1,k + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,j) = locx(i,jlx+j-1) + end do + end do + + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,j) = szero + end if + end do + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_sgatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_sgatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - real,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - real,dimension(:). The local piece of the distributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! default: -1 +! +subroutine psb_sgatherv(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_sgatherv + implicit none + + real(psb_spk_), intent(in) :: locx(:) + real(psb_spk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_sgatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + lda_globx = m + lda_locx = size(locx) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=szero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = szero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_sgatherv + diff --git a/base/comm/psb_shalo.f90 b/base/comm/psb_shalo.f90 index 51a86ca03..c18524143 100644 --- a/base/comm/psb_shalo.f90 +++ b/base/comm/psb_shalo.f90 @@ -52,345 +52,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_shalom - use psi_mod - implicit none - - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_, ldx - real(psb_spk_),pointer :: iwork(:), xp(:,:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_shalom' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - xp => x(iix:size(x,1),jjx:jjx+k-1) - if(tran_ == 'N') then - call psi_swapdata(imode,k,szero,xp,& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,k,sone,xp,& - &desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_cswapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_shalom - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_shalov -! This subroutine performs the exchange of the halo elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x - real,dimension(:). The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! jx - integer(optional). The starting column of the global matrix. -! ik - integer(optional). The number of columns to gather. -! work - real(optional). Work area. -! tran - character(optional). Transpose exchange. -! mode - integer(optional). Communication mode (see Swapdata) -! data - integer Which index list in desc_a should be used -! to retrieve rows, default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psb_shalov(x,desc_a,info,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_shalov - use psi_mod - implicit none - - real(psb_spk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, ldx, & - & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ - real(psb_spk_),pointer :: iwork(:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_shalov' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - if(tran_ == 'N') then - call psi_swapdata(imode,szero,x(iix:size(x)),& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,sone,x(iix:size(x)),& - & desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_shalov - subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_shalo_vect @@ -405,18 +66,20 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_shalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -458,7 +121,7 @@ subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -544,18 +207,20 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_shalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -597,7 +262,7 @@ subroutine psb_shalo_multivect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_shalo_a.f90 b/base/comm/psb_shalo_a.f90 new file mode 100644 index 000000000..14d97025a --- /dev/null +++ b/base/comm/psb_shalo_a.f90 @@ -0,0 +1,398 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_shalo.f90 +! +! Subroutine: psb_shalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - real,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - real(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_shalom + use psi_mod + implicit none + + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_spk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_shalom' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,szero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,sone,xp,& + &desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_cswapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_shalom + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_shalov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - real(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_shalov(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_shalov + use psi_mod + implicit none + + real(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_spk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_shalov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,szero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,sone,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_shalov + diff --git a/base/comm/psb_sovrl.f90 b/base/comm/psb_sovrl.f90 index 9b2155f48..0635a03b9 100644 --- a/base/comm/psb_sovrl.f90 +++ b/base/comm/psb_sovrl.f90 @@ -63,322 +63,6 @@ ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -! -subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) - use psb_base_mod, psb_protect_name => psb_sovrlm - use psi_mod - implicit none - - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork, ldx - real(psb_spk_),pointer :: iwork(:), xp(:,:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_sovrlm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - ! exchange overlap elements - if(do_swap) then - xp => x(iix:ldx,jjx:jjx+k-1) - call psi_swapdata(mode_,k,sone,xp,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_sovrlm -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_sovrlv -! This subroutine performs the exchange of the overlap elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x(:) - real The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. -! work - real(optional). A work area. -! update - integer(optional). Type of update: -! psb_none_ do nothing -! psb_sum_ sum of overlaps -! psb_avg_ average of overlaps -! mode - integer(optional). Choose the algorithm for data exchange: -! this is chosen through bit fields. -! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! - swap_sync = iand(flag,psb_swap_sync_) /= 0 -! - swap_send = iand(flag,psb_swap_send_) /= 0 -! - swap_recv = iand(flag,psb_swap_recv_) /= 0 -! - if (swap_mpi): use underlying MPI_ALLTOALLV. -! - if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! - if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! - if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! - if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -subroutine psb_sovrlv(x,desc_a,info,work,update,mode) - use psb_base_mod, psb_protect_name => psb_sovrlv - use psi_mod - implicit none - - real(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - - ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork, ldx - real(psb_spk_),pointer :: iwork(:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_sovrlv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - k = 1 - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - - ! exchange overlap elements - if (do_swap) then - call psi_swapdata(mode_,sone,x,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_sovrlv - - subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) use psb_base_mod, psb_protect_name => psb_sovrl_vect use psi_mod @@ -391,18 +75,20 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_sovrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -443,7 +129,7 @@ subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -516,18 +202,20 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx real(psb_spk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_sovrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -568,7 +256,7 @@ subroutine psb_sovrl_multivect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_sovrl_a.f90 b/base/comm/psb_sovrl_a.f90 new file mode 100644 index 000000000..e38048868 --- /dev/null +++ b/base/comm/psb_sovrl_a.f90 @@ -0,0 +1,384 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_sovrl.f90 +! +! Subroutine: psb_sovrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - real The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_base_mod, psb_protect_name => psb_sovrlm + use psi_mod + implicit none + + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_spk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_sovrlm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:ldx,jjx:jjx+k-1) + call psi_swapdata(mode_,k,sone,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_sovrlm +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_sovrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - real The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - real(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_sovrlv(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_sovrlv + use psi_mod + implicit none + + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + & k, update_, mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + real(psb_spk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_sovrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,sone,x,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_sovrlv diff --git a/base/comm/psb_sscatter.F90 b/base/comm/psb_sscatter.F90 index 2df167eae..60bdd342d 100644 --- a/base/comm/psb_sscatter.F90 +++ b/base/comm/psb_sscatter.F90 @@ -43,456 +43,6 @@ ! iroot - integer(optional). The process that owns the global matrix. ! If -1 all the processes have a copy. ! Default -1 -subroutine psb_sscatterm(globx, locx, desc_a, info, root) - - use psb_base_mod, psb_protect_name => psb_sscatterm -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - real(psb_spk_), intent(out), allocatable :: locx(:,:) - real(psb_spk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & - & col,pos - real(psb_spk_),allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - - name='psb_scatterm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot >= np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - iglobx = 1 - jglobx = 1 - lda_globx = size(globx,1) - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,me) - - if (iroot==-1) then - lda_globx = size(globx, 1) - k = size(globx,2) - else - if (iam==iroot) then - k = size(globx,2) - lda_globx = size(globx, 1) - end if - end if - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow=desc_a%get_local_rows() - ! root has to gather size information - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - - call psb_geall(locx,desc_a,info,n=k) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do j=1,k - do i=1, nrow - locx(i,j)=globx(ltg(i),j) - end do - end do - else - - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if (iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1)+all_dim(i-1) - end do - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - do col=1, k - ! prepare vector to scatter - if(iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx,col) - end do - end do - end if - - ! scatter - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_r_spk_,locx(1,col),nrow,& - & psb_mpi_r_spk_,rootrank,icomm,info) - - end do - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - end if - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_sscatterm - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -! Subroutine: psb_sscatterv -! This subroutine scatters a global vector locally owned by one process -! into pieces that are local to alle the processes. -! -! Arguments: -! globx - real,dimension(:). The global vector to scatter. -! locx - real,dimension(:). The local piece of the ditributed vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! iroot - integer(optional). The process that owns the global vector. If -1 all -! the processes have a copy. -! -subroutine psb_sscatterv(globx, locx, desc_a, info, root) - use psb_base_mod, psb_protect_name => psb_sscatterv -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - real(psb_spk_), intent(out), allocatable :: locx(:) - real(psb_spk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx - real(psb_spk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - integer(psb_ipk_) :: debug_level, debug_unit - - name='psb_scatterv' - if (psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - ictxt=desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,iam) - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - if ((iroot==-1).or.(iam==iroot))& - & lda_globx = size(globx, 1) - - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - k = 1 - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow = desc_a%get_local_rows() - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - call psb_geall(locx,desc_a,info) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do i=1, nrow - locx(i)=globx(ltg(i)) - end do - else - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if(iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1) + all_dim(i-1) - end do - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & - &' dim',all_dim(1:np), sum(all_dim) - endif - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - ! prepare vector to scatter - if (iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx) - - end do - end do - end if - - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_r_spk_,locx,nrow,& - & psb_mpi_r_spk_,rootrank,icomm,info) - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_sscatterv - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ subroutine psb_sscatter_vect(globx, locx, desc_a, info, root, mold) use psb_base_mod, psb_protect_name => psb_sscatter_vect implicit none @@ -504,7 +54,7 @@ subroutine psb_sscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_s_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpik_) :: ictxt, np, me, icomm, myrank, rootrank + integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx real(psb_spk_), allocatable :: vlocx(:) @@ -512,9 +62,11 @@ subroutine psb_sscatter_vect(globx, locx, desc_a, info, root, mold) integer(psb_ipk_) :: debug_level, debug_unit name='psb_scatter_vect' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/comm/psb_sscatter_a.F90 b/base/comm/psb_sscatter_a.F90 new file mode 100644 index 000000000..e908a8239 --- /dev/null +++ b/base/comm/psb_sscatter_a.F90 @@ -0,0 +1,480 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_sscatter.f90 +! +! Subroutine: psb_sscatterm +! This subroutine scatters a global matrix locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - real,dimension(:,:). The global matrix to scatter. +! locx - real,dimension(:,:). The local piece of the distributed matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_sscatterm(globx, locx, desc_a, info, root) + + use psb_base_mod, psb_protect_name => psb_sscatterm +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + real(psb_spk_), intent(out), allocatable :: locx(:,:) + real(psb_spk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & + & col,pos + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + real(psb_spk_),allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + + name='psb_scatterm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot >= np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + iglobx = 1 + jglobx = 1 + lda_globx = size(globx,1) + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) + + if (iroot==-1) then + lda_globx = size(globx, 1) + k = size(globx,2) + else + if (iam==iroot) then + k = size(globx,2) + lda_globx = size(globx, 1) + end if + end if + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow=desc_a%get_local_rows() + ! root has to gather size information + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + + call psb_geall(locx,desc_a,info,n=k) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do j=1,k + do i=1, nrow + locx(i,j)=globx(ltg(i),j) + end do + end do + else + + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if (iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1)+all_dim(i-1) + end do + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + do col=1, k + ! prepare vector to scatter + if(iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx,col) + end do + end do + end if + + ! scatter + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_r_spk_,locx(1,col),nrow,& + & psb_mpi_r_spk_,rootrank,icomm,info) + + end do + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_sscatterm + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +! Subroutine: psb_sscatterv +! This subroutine scatters a global vector locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - real,dimension(:). The global vector to scatter. +! locx - real,dimension(:). The local piece of the ditributed vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! iroot - integer(optional). The process that owns the global vector. If -1 all +! the processes have a copy. +! +subroutine psb_sscatterv(globx, locx, desc_a, info, root) + use psb_base_mod, psb_protect_name => psb_sscatterv +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + real(psb_spk_), intent(out), allocatable :: locx(:) + real(psb_spk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + real(psb_spk_), allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scatterv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt=desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,iam) + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + if ((iroot==-1).or.(iam==iroot))& + & lda_globx = size(globx, 1) + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + k = 1 + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call psb_geall(locx,desc_a,info) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do i=1, nrow + locx(i)=globx(ltg(i)) + end do + else + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if(iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1) + all_dim(i-1) + end do + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & + &' dim',all_dim(1:np), sum(all_dim) + endif + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + ! prepare vector to scatter + if (iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx) + + end do + end do + end if + + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_r_spk_,locx,nrow,& + & psb_mpi_r_spk_,rootrank,icomm,info) + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_sscatterv + diff --git a/base/comm/psb_sspgather.F90 b/base/comm/psb_sspgather.F90 index f0f828bd5..27444ecd4 100644 --- a/base/comm/psb_sspgather.F90 +++ b/base/comm/psb_sspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_sspgather.f90 subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -51,21 +54,183 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep logical, intent(in), optional :: keepnum,keeploc type(psb_s_coo_sparse_mat) :: loc_coo, glob_coo - integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg - integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + integer(psb_ipk_) :: nrg, ncg, nzg, nzl + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpik_) :: ictxt,np,me - integer(psb_mpik_) :: icomm, minfo, ndx - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit name='psb_gather' - if (psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_realloc(nzl,locia,info) + call psb_realloc(nzl,locja,info) + call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + + if (info == psb_success_) call psb_realloc(nzg,glbia,info) + if (info == psb_success_) call psb_realloc(nzg,glbja,info) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_spk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,& + & glbia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,& + & glbja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + deallocate(locia,locja, stat=info) + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + glob_coo%ia(1:nzg) = glbia(1:nzg) + glob_coo%ja(1:nzg) = glbja(1:nzg) + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + deallocate(glbia,glbja, stat=info) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_ssp_allgather + + +subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_sspmat_type), intent(inout) :: loca + type(psb_lsspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_ls_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() icomm = desc_a%get_mpic() call psb_info(ictxt, me, np) @@ -86,10 +251,9 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - allocate(nzbr(np), idisp(np),stat=info) + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) if (info /= psb_success_) then - info=psb_err_alloc_request_ - ierr(1) = 2*np + info=psb_err_alloc_request_; ierr(1) = 3*np call psb_errpush(info,name,i_err=ierr,a_err='integer') goto 9999 end if @@ -106,9 +270,25 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(:) = 0 nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 + ! + ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING + ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo @@ -117,21 +297,168 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep & glob_coo%val,nzbr,idisp,& & psb_mpi_r_spk_,icomm,minfo) if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& & glob_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) + & psb_mpi_lpk_,icomm,minfo) if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& & glob_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) + & psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 - end if - + end if call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lssp_allgather + +subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_lsspmat_type), intent(inout) :: loca + type(psb_lsspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_ls_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1) = 3*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr + nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_r_spk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_r_spk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! call glob_coo%set_nzeros(nzg) if (present(dupl)) call glob_coo%set_dupl(dupl) call globa%mv_from(glob_coo) @@ -153,4 +480,4 @@ subroutine psb_ssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep return -end subroutine psb_ssp_allgather +end subroutine psb_lslssp_allgather diff --git a/base/comm/psb_zgather.f90 b/base/comm/psb_zgather.f90 index b91d43296..d22e6644a 100644 --- a/base/comm/psb_zgather.f90 +++ b/base/comm/psb_zgather.f90 @@ -45,291 +45,6 @@ ! global matrix. If -1 all ! the processes will have a copy. ! -subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_zgatherm - implicit none - - complex(psb_dpk_), intent(in) :: locx(:,:) - complex(psb_dpk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, & - & ilx, i, j, idx - - character(len=20) :: name, ch_err - - name='psb_zgatherm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - if (root == -1) then - iiroot = psb_root_ - else - iiroot = root - endif - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - lda_globx = m - lda_locx = size(locx, 1) - lock = size(locx,2) - maxk = lock - k = maxk - - call psb_bcast(ictxt,k,root=iiroot) - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,k,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:,:)=zzero - - do j=1,k - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx,j) = locx(i,jlx+j-1) - end do - end do - - do j=1,k - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx,j) = zzero - end if - end do - end do - - call psb_sum(ictxt,globx(1:m,1:k),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_zgatherm - - - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_zgatherv -! This subroutine gathers pieces of a distributed dense vector into a local one. -! -! Arguments: -! globx - complex,dimension(:). The local vector into which gather -! the distributed pieces. -! locx - complex,dimension(:). The local piece of the distributed -! vector to be gathered. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Error code. -! iroot - integer. The process that has to own the -! global matrix. If -1 all -! the processes will have a copy. -! default: -1 -! -subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) - use psb_base_mod, psb_protect_name => psb_zgatherv - implicit none - - complex(psb_dpk_), intent(in) :: locx(:) - complex(psb_dpk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: iroot - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx - - character(len=20) :: name, ch_err - - name='psb_zgatherv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(iroot)) then - root = iroot - if((root < -1).or.(root > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=root - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - root = -1 - end if - - jglobx=1 - iglobx = 1 - jlocx=1 - ilocx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - lda_globx = m - lda_locx = size(locx) - - k = 1 - - - ! there should be a global check on k here!!! - - call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if (info == psb_success_) & - & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - if ((ilx /= 1).or.(iglobx /= 1)) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - goto 9999 - end if - - call psb_realloc(m,globx,info) - if (info /= psb_success_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - globx(:)=zzero - - do i=1,desc_a%get_local_rows() - call psb_loc_to_glob(i,idx,desc_a,info) - globx(idx) = locx(i) - end do - - ! adjust overlapped elements - do i=1, size(desc_a%ovrlap_elem,1) - if (me /= desc_a%ovrlap_elem(i,3)) then - idx = desc_a%ovrlap_elem(i,1) - call psb_loc_to_glob(idx,desc_a,info) - globx(idx) = zzero - end if - end do - - call psb_sum(ictxt,globx(1:m),root=root) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_zgatherv - - - subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) use psb_base_mod, psb_protect_name => psb_zgather_vect implicit none @@ -342,16 +57,18 @@ subroutine psb_zgather_vect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_dpk_), allocatable :: llocx(:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -455,16 +172,18 @@ subroutine psb_zgather_multivect(globx, locx, desc_a, info, iroot) ! locals - integer(psb_mpik_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, n, ilocx, iglobx, jlocx,& - & jglobx, lda_locx, lda_globx, m, k, jlx, ilx, i, idx + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, jlx, ilx, lda_locx, lda_globx, i + integer(psb_lpk_) :: m, n, k, ilocx, jlocx, idx, iglobx, jglobx complex(psb_dpk_), allocatable :: llocx(:,:) character(len=20) :: name, ch_err name='psb_cgatherv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/comm/psb_zgather_a.f90 b/base/comm/psb_zgather_a.f90 new file mode 100644 index 000000000..d2c9bd91d --- /dev/null +++ b/base/comm/psb_zgather_a.f90 @@ -0,0 +1,335 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zgather.f90 +! +! Subroutine: psb_zgatherm +! This subroutine gathers pieces of a distributed dense matrix into a local one. +! +! Arguments: +! globx - complex,dimension(:,:). The local matrix into which gather +! the distributed pieces. +! locx - complex,dimension(:,:). The local piece of the distributed +! matrix to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! +subroutine psb_zgatherm(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_zgatherm + implicit none + + complex(psb_dpk_), intent(in) :: locx(:,:) + complex(psb_dpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_zgatherm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + if (root == -1) then + iiroot = psb_root_ + else + iiroot = root + endif + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + lda_globx = m + lda_locx = size(locx, 1) + lock = size(locx,2) + maxk = lock + k = maxk + + call psb_bcast(ictxt,k,root=iiroot) + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,k,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:,:)=zzero + + do j=1,k + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx,j) = locx(i,jlx+j-1) + end do + end do + + do j=1,k + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx,j) = zzero + end if + end do + end do + + call psb_sum(ictxt,globx(1:m,1:k),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_zgatherm + + + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_zgatherv +! This subroutine gathers pieces of a distributed dense vector into a local one. +! +! Arguments: +! globx - complex,dimension(:). The local vector into which gather +! the distributed pieces. +! locx - complex,dimension(:). The local piece of the distributed +! vector to be gathered. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer. The process that has to own the +! global matrix. If -1 all +! the processes will have a copy. +! default: -1 +! +subroutine psb_zgatherv(globx, locx, desc_a, info, iroot) + use psb_base_mod, psb_protect_name => psb_zgatherv + implicit none + + complex(psb_dpk_), intent(in) :: locx(:) + complex(psb_dpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iroot + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, root, iiroot, icomm, myrank, rootrank + integer(psb_ipk_) :: ierr(5), err_act, lda_locx, lda_globx, lock, globk,& + & maxk, k, jlx, ilx, i, j + integer(psb_lpk_) :: m, n, ilocx, jlocx, idx, iglobx, jglobx + + character(len=20) :: name, ch_err + + name='psb_zgatherv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(iroot)) then + root = iroot + if((root < -1).or.(root > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=root + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + root = -1 + end if + + jglobx=1 + iglobx = 1 + jlocx=1 + ilocx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + lda_globx = m + lda_locx = size(locx) + + k = 1 + + + ! there should be a global check on k here!!! + + call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if (info == psb_success_) & + & call psb_chkvect(m,n,lda_locx,ilocx,jlocx,desc_a,info,ilx,jlx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if ((ilx /= 1).or.(iglobx /= 1)) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(m,globx,info) + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + globx(:)=zzero + + do i=1,desc_a%get_local_rows() + call psb_loc_to_glob(i,idx,desc_a,info) + globx(idx) = locx(i) + end do + + ! adjust overlapped elements + do i=1, size(desc_a%ovrlap_elem,1) + if (me /= desc_a%ovrlap_elem(i,3)) then + idx = desc_a%ovrlap_elem(i,1) + call psb_loc_to_glob(idx,desc_a,info) + globx(idx) = zzero + end if + end do + + call psb_sum(ictxt,globx(1:m),root=root) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_zgatherv + diff --git a/base/comm/psb_zhalo.f90 b/base/comm/psb_zhalo.f90 index 4446da8b3..f6c4b45a8 100644 --- a/base/comm/psb_zhalo.f90 +++ b/base/comm/psb_zhalo.f90 @@ -52,345 +52,6 @@ ! psb_comm_mov_ use ovr_mst_idx ! ! -subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_zhalom - use psi_mod - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, k, maxk, nrow, imode, i,& - & err, liwork,data_, ldx - complex(psb_dpk_),pointer :: iwork(:), xp(:,:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_zhalom' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - xp => x(iix:size(x,1),jjx:jjx+k-1) - if(tran_ == 'N') then - call psi_swapdata(imode,k,zzero,xp,& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,k,zone,xp,& - &desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_cswapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_zhalom - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_zhalov -! This subroutine performs the exchange of the halo elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x - real,dimension(:). The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! jx - integer(optional). The starting column of the global matrix. -! ik - integer(optional). The number of columns to gather. -! work - complex(optional). Work area. -! tran - character(optional). Transpose exchange. -! mode - integer(optional). Communication mode (see Swapdata) -! data - integer Which index list in desc_a should be used -! to retrieve rows, default psb_comm_halo_ -! psb_comm_halo_ use halo_index -! psb_comm_ext_ use ext_index -! psb_comm_ovrl_ use ovrl_index -! psb_comm_mov_ use ovr_mst_idx -! -! -subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data) - use psb_base_mod, psb_protect_name => psb_zhalov - use psi_mod - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, ldx, & - & m, n, iix, jjx, ix, ijx, nrow, imode, err, liwork,data_ - complex(psb_dpk_),pointer :: iwork(:) - character :: tran_ - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_zhalov' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - - if (present(tran)) then - tran_ = psb_toupper(tran) - else - tran_ = 'N' - endif - if (present(data)) then - data_ = data - else - data_ = psb_comm_halo_ - endif - if (present(mode)) then - imode = mode - else - imode = IOR(psb_swap_send_,psb_swap_recv_) - endif - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - liwork=nrow - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - iwork => work - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - else - aliw=.true. - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_realloc' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - ! exchange halo elements - if(tran_ == 'N') then - call psi_swapdata(imode,zzero,x(iix:size(x)),& - & desc_a,iwork,info,data=data_) - else if((tran_ == 'T').or.(tran_ == 'C')) then - call psi_swaptran(imode,zone,x(iix:size(x)),& - & desc_a,iwork,info) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid tran') - goto 9999 - end if - - if(info /= psb_success_) then - ch_err='PSI_swapdata' - call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_zhalov - subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) use psb_base_mod, psb_protect_name => psb_zhalo_vect @@ -405,18 +66,20 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_zhalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -458,7 +121,7 @@ subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -544,18 +207,20 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data) character, intent(in), optional :: tran ! locals - integer(psb_ipk_) :: ictxt, np, me,& - & err_act, m, n, iix, jjx, ix, ijx, nrow, imode,& - & err, liwork,data_ + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, & + & nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) character :: tran_ character(len=20) :: name, ch_err logical :: aliw name='psb_zhalov' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -597,7 +262,7 @@ subroutine psb_zhalo_multivect(x,desc_a,info,work,tran,mode,data) endif ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_zhalo_a.f90 b/base/comm/psb_zhalo_a.f90 new file mode 100644 index 000000000..ed94747b1 --- /dev/null +++ b/base/comm/psb_zhalo_a.f90 @@ -0,0 +1,398 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zhalo.f90 +! +! Subroutine: psb_zhalom +! This subroutine performs the exchange of the halo elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x - complex,dimension(:,:). The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - complex(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_zhalom + use psi_mod + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, k, maxk, nrow, imode, i,& + & err, liwork,data_, ldx + integer(psb_lpk_) :: m, n, ix, ijx + complex(psb_dpk_),pointer :: iwork(:), xp(:,:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_zhalom' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + xp => x(iix:size(x,1),jjx:jjx+k-1) + if(tran_ == 'N') then + call psi_swapdata(imode,k,zzero,xp,& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,k,zone,xp,& + &desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_cswapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_zhalom + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_zhalov +! This subroutine performs the exchange of the halo elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x - real,dimension(:). The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! jx - integer(optional). The starting column of the global matrix. +! ik - integer(optional). The number of columns to gather. +! work - complex(optional). Work area. +! tran - character(optional). Transpose exchange. +! mode - integer(optional). Communication mode (see Swapdata) +! data - integer Which index list in desc_a should be used +! to retrieve rows, default psb_comm_halo_ +! psb_comm_halo_ use halo_index +! psb_comm_ext_ use ext_index +! psb_comm_ovrl_ use ovrl_index +! psb_comm_mov_ use ovr_mst_idx +! +! +subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data) + use psb_base_mod, psb_protect_name => psb_zhalov + use psi_mod + implicit none + + complex(psb_dpk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, ldx, iix, jjx, nrow, imode, err, liwork,data_ + integer(psb_lpk_) :: m, n, ix, ijx + complex(psb_dpk_),pointer :: iwork(:) + character :: tran_ + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_zhalov' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + + if (present(tran)) then + tran_ = psb_toupper(tran) + else + tran_ = 'N' + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + if (present(mode)) then + imode = mode + else + imode = IOR(psb_swap_send_,psb_swap_recv_) + endif + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + liwork=nrow + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + iwork => work + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + else + aliw=.true. + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_realloc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + ! exchange halo elements + if(tran_ == 'N') then + call psi_swapdata(imode,zzero,x(iix:size(x)),& + & desc_a,iwork,info,data=data_) + else if((tran_ == 'T').or.(tran_ == 'C')) then + call psi_swaptran(imode,zone,x(iix:size(x)),& + & desc_a,iwork,info) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid tran') + goto 9999 + end if + + if(info /= psb_success_) then + ch_err='PSI_swapdata' + call psb_errpush(psb_err_from_subroutine_,name,a_err=ch_err) + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_zhalov + diff --git a/base/comm/psb_zovrl.f90 b/base/comm/psb_zovrl.f90 index 50e907e4c..88707d9d4 100644 --- a/base/comm/psb_zovrl.f90 +++ b/base/comm/psb_zovrl.f90 @@ -63,322 +63,6 @@ ! - if (swap_recv): use psb_rcv (completing a ! previous call with swap_send) ! -! -subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) - use psb_base_mod, psb_protect_name => psb_zovrlm - use psi_mod - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - - ! locals - integer(psb_mpik_) :: ictxt, np, me - integer(psb_ipk_) :: err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, maxk, update_,& - & mode_, err, liwork, ldx - complex(psb_dpk_),pointer :: iwork(:), xp(:,:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_zovrlm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - if (present(jx)) then - ijx = jx - else - ijx = 1 - endif - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - maxk=size(x,2)-ijx+1 - - if(present(ik)) then - if(ik > maxk) then - k=maxk - else - k=ik - end if - else - k = maxk - end if - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - ! exchange overlap elements - if(do_swap) then - xp => x(iix:ldx,jjx:jjx+k-1) - call psi_swapdata(mode_,k,zone,xp,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_zovrlm -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Subroutine: psb_zovrlv -! This subroutine performs the exchange of the overlap elements in a -! distributed dense vector between all the processes. -! -! Arguments: -! x(:) - complex The local part of the dense vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code. -! work - complex(optional). A work area. -! update - integer(optional). Type of update: -! psb_none_ do nothing -! psb_sum_ sum of overlaps -! psb_avg_ average of overlaps -! mode - integer(optional). Choose the algorithm for data exchange: -! this is chosen through bit fields. -! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 -! - swap_sync = iand(flag,psb_swap_sync_) /= 0 -! - swap_send = iand(flag,psb_swap_send_) /= 0 -! - swap_recv = iand(flag,psb_swap_recv_) /= 0 -! - if (swap_mpi): use underlying MPI_ALLTOALLV. -! - if (swap_sync): use PSB_SND and PSB_RCV in -! synchronized pairs -! - if (swap_send .and. swap_recv): use mpi_irecv -! and mpi_send -! - if (swap_send): use psb_snd (but need another -! call with swap_recv to complete) -! - if (swap_recv): use psb_rcv (completing a -! previous call with swap_send) -! -! -subroutine psb_zovrlv(x,desc_a,info,work,update,mode) - use psb_base_mod, psb_protect_name => psb_zovrlv - use psi_mod - implicit none - - complex(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), optional, target, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - - ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork, ldx - complex(psb_dpk_),pointer :: iwork(:) - logical :: do_swap - character(len=20) :: name, ch_err - logical :: aliw - - name='psb_zovrlv' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - ix = 1 - ijx = 1 - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - - k = 1 - - if (present(update)) then - update_ = update - else - update_ = psb_avg_ - endif - - if (present(mode)) then - mode_ = mode - else - mode_ = IOR(psb_swap_send_,psb_swap_recv_) - endif - do_swap = (mode_ /= 0) - ldx = size(x,1) - ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chkvect' - call psb_errpush(info,name,a_err=ch_err) - end if - - if (iix /= 1) then - info=psb_err_ix_n1_iy_n1_unsupported_ - call psb_errpush(info,name) - end if - - err=info - call psb_errcomm(ictxt,err) - if(err /= 0) goto 9999 - - ! check for presence/size of a work area - liwork=ncol - if (present(work)) then - if(size(work) >= liwork) then - aliw=.false. - else - aliw=.true. - end if - else - aliw=.true. - end if - if (aliw) then - allocate(iwork(liwork),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='Allocate') - goto 9999 - end if - else - iwork => work - end if - - ! exchange overlap elements - if (do_swap) then - call psi_swapdata(mode_,zone,x,& - & desc_a,iwork,info,data=psb_comm_ovr_) - end if - if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') - goto 9999 - end if - - if (aliw) deallocate(iwork) - nullify(iwork) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return -end subroutine psb_zovrlv - - subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) use psb_base_mod, psb_protect_name => psb_zovrl_vect use psi_mod @@ -391,18 +75,20 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_zovrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -443,7 +129,7 @@ subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -516,18 +202,20 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode) integer(psb_ipk_), intent(in), optional :: update,mode ! locals - integer(psb_ipk_) :: ictxt, np, me, & - & err_act, m, n, iix, jjx, ix, ijx, nrow, ncol, k, update_,& - & mode_, err, liwork,ldx + integer(psb_ipk_) :: ictxt, np, me, err_act, k, iix, jjx, & + & nrow, imode, err, liwork,data_, update_, mode_, ncol + integer(psb_lpk_) :: m, n, ix, ijx complex(psb_dpk_),pointer :: iwork(:) logical :: do_swap character(len=20) :: name, ch_err logical :: aliw name='psb_zovrlv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -568,7 +256,7 @@ subroutine psb_zovrl_multivect(x,desc_a,info,work,update,mode) do_swap = (mode_ /= 0) ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/comm/psb_zovrl_a.f90 b/base/comm/psb_zovrl_a.f90 new file mode 100644 index 000000000..b392bc315 --- /dev/null +++ b/base/comm/psb_zovrl_a.f90 @@ -0,0 +1,384 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_zovrl.f90 +! +! Subroutine: psb_zovrlm +! This subroutine performs the exchange of the overlap elements in a +! distributed dense matrix between all the processes. +! +! Arguments: +! x(:,:) - complex The local part of the dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! jx - integer(optional). The starting column of the global matrix +! ik - integer(optional). The number of columns to gather. +! work - complex(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) + use psb_base_mod, psb_protect_name => psb_zovrlm + use psi_mod + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + + ! locals + integer(psb_mpk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act, iix, jjx, nrow, ncol, k, maxk, update_,& + & mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + complex(psb_dpk_),pointer :: iwork(:), xp(:,:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_zovrlm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + if (present(jx)) then + ijx = jx + else + ijx = 1 + endif + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + maxk=size(x,2)-ijx+1 + + if(present(ik)) then + if(ik > maxk) then + k=maxk + else + k=ik + end if + else + k = maxk + end if + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + ! exchange overlap elements + if(do_swap) then + xp => x(iix:ldx,jjx:jjx+k-1) + call psi_swapdata(mode_,k,zone,xp,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(xp,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_zovrlm +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Subroutine: psb_zovrlv +! This subroutine performs the exchange of the overlap elements in a +! distributed dense vector between all the processes. +! +! Arguments: +! x(:) - complex The local part of the dense vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code. +! work - complex(optional). A work area. +! update - integer(optional). Type of update: +! psb_none_ do nothing +! psb_sum_ sum of overlaps +! psb_avg_ average of overlaps +! mode - integer(optional). Choose the algorithm for data exchange: +! this is chosen through bit fields. +! - swap_mpi = iand(flag,psb_swap_mpi_) /= 0 +! - swap_sync = iand(flag,psb_swap_sync_) /= 0 +! - swap_send = iand(flag,psb_swap_send_) /= 0 +! - swap_recv = iand(flag,psb_swap_recv_) /= 0 +! - if (swap_mpi): use underlying MPI_ALLTOALLV. +! - if (swap_sync): use PSB_SND and PSB_RCV in +! synchronized pairs +! - if (swap_send .and. swap_recv): use mpi_irecv +! and mpi_send +! - if (swap_send): use psb_snd (but need another +! call with swap_recv to complete) +! - if (swap_recv): use psb_rcv (completing a +! previous call with swap_send) +! +! +subroutine psb_zovrlv(x,desc_a,info,work,update,mode) + use psb_base_mod, psb_protect_name => psb_zovrlv + use psi_mod + implicit none + + complex(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), optional, target, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + + ! locals + integer(psb_ipk_) :: ictxt, np, me, err_act, iix, jjx, nrow, ncol, & + & k, update_, mode_, err, liwork, ldx + integer(psb_lpk_) :: m, n, ix, ijx + complex(psb_dpk_),pointer :: iwork(:) + logical :: do_swap + character(len=20) :: name, ch_err + logical :: aliw + + name='psb_zovrlv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = 1 + ijx = 1 + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + k = 1 + + if (present(update)) then + update_ = update + else + update_ = psb_avg_ + endif + + if (present(mode)) then + mode_ = mode + else + mode_ = IOR(psb_swap_send_,psb_swap_recv_) + endif + do_swap = (mode_ /= 0) + ldx = size(x,1) + ! check vector correctness + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect' + call psb_errpush(info,name,a_err=ch_err) + end if + + if (iix /= 1) then + info=psb_err_ix_n1_iy_n1_unsupported_ + call psb_errpush(info,name) + end if + + err=info + call psb_errcomm(ictxt,err) + if(err /= 0) goto 9999 + + ! check for presence/size of a work area + liwork=ncol + if (present(work)) then + if(size(work) >= liwork) then + aliw=.false. + else + aliw=.true. + end if + else + aliw=.true. + end if + if (aliw) then + allocate(iwork(liwork),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='Allocate') + goto 9999 + end if + else + iwork => work + end if + + ! exchange overlap elements + if (do_swap) then + call psi_swapdata(mode_,zone,x,& + & desc_a,iwork,info,data=psb_comm_ovr_) + end if + if (info == psb_success_) call psi_ovrl_upd(x,desc_a,update_,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates') + goto 9999 + end if + + if (aliw) deallocate(iwork) + nullify(iwork) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return +end subroutine psb_zovrlv diff --git a/base/comm/psb_zscatter.F90 b/base/comm/psb_zscatter.F90 index 0d99738b7..008f80849 100644 --- a/base/comm/psb_zscatter.F90 +++ b/base/comm/psb_zscatter.F90 @@ -43,456 +43,6 @@ ! iroot - integer(optional). The process that owns the global matrix. ! If -1 all the processes have a copy. ! Default -1 -subroutine psb_zscatterm(globx, locx, desc_a, info, root) - - use psb_base_mod, psb_protect_name => psb_zscatterm -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - complex(psb_dpk_), intent(out), allocatable :: locx(:,:) - complex(psb_dpk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & - & col,pos - complex(psb_dpk_),allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - - name='psb_scatterm' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot >= np)) then - info=psb_err_input_value_invalid_i_ - ierr(1)=5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - iglobx = 1 - jglobx = 1 - lda_globx = size(globx,1) - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,me) - - if (iroot==-1) then - lda_globx = size(globx, 1) - k = size(globx,2) - else - if (iam==iroot) then - k = size(globx,2) - lda_globx = size(globx, 1) - end if - end if - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow=desc_a%get_local_rows() - ! root has to gather size information - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - - call psb_geall(locx,desc_a,info,n=k) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do j=1,k - do i=1, nrow - locx(i,j)=globx(ltg(i),j) - end do - end do - else - - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if (iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1)+all_dim(i-1) - end do - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - do col=1, k - ! prepare vector to scatter - if(iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx,col) - end do - end do - end if - - ! scatter - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_c_dpk_,locx(1,col),nrow,& - & psb_mpi_c_dpk_,rootrank,icomm,info) - - end do - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - end if - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_zscatterm - - - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ - -! Subroutine: psb_zscatterv -! This subroutine scatters a global vector locally owned by one process -! into pieces that are local to alle the processes. -! -! Arguments: -! globx - complex,dimension(:). The global vector to scatter. -! locx - complex,dimension(:). The local piece of the ditributed vector. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -! iroot - integer(optional). The process that owns the global vector. If -1 all -! the processes have a copy. -! -subroutine psb_zscatterv(globx, locx, desc_a, info, root) - use psb_base_mod, psb_protect_name => psb_zscatterv -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - - complex(psb_dpk_), intent(out), allocatable :: locx(:) - complex(psb_dpk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - - - ! locals - integer(psb_mpik_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank - integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& - & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx - complex(psb_dpk_), allocatable :: scatterv(:) - integer(psb_ipk_), allocatable :: displ(:), l_t_g_all(:), all_dim(:), ltg(:) - character(len=20) :: name, ch_err - integer(psb_ipk_) :: debug_level, debug_unit - - name='psb_scatterv' - if (psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - ictxt=desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! check on blacs grid - call psb_info(ictxt, iam, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(root)) then - iroot = root - if((iroot < -1).or.(iroot > np)) then - info=psb_err_input_value_invalid_i_ - ierr(1) = 5; ierr(2)=iroot - call psb_errpush(info,name,i_err=ierr) - goto 9999 - end if - else - iroot = psb_root_ - end if - - call psb_get_mpicomm(ictxt,icomm) - call psb_get_rank(myrank,ictxt,iam) - - iglobx = 1 - jglobx = 1 - ilocx = 1 - jlocx = 1 - if ((iroot==-1).or.(iam==iroot))& - & lda_globx = size(globx, 1) - - - m = desc_a%get_global_rows() - n = desc_a%get_global_cols() - - k = 1 - ! there should be a global check on k here!!! - if ((iroot==-1).or.(iam==iroot)) & - & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) - - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_chk(glob)vect' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - nrow = desc_a%get_local_rows() - allocate(displ(np),all_dim(np),ltg(nrow),stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do i=1, nrow - ltg(i) = i - end do - call psb_loc_to_glob(ltg(1:nrow),desc_a,info) - call psb_geall(locx,desc_a,info) - - if ((iroot == -1).or.(np == 1)) then - ! extract my chunk - do i=1, nrow - locx(i)=globx(ltg(i)) - end do - else - call psb_get_rank(rootrank,ictxt,iroot) - - call mpi_gather(nrow,1,psb_mpi_ipk_integer,all_dim,& - & 1,psb_mpi_ipk_integer,rootrank,icomm,info) - - if(iam == iroot) then - displ(1)=0 - do i=2,np - displ(i)=displ(i-1) + all_dim(i-1) - end do - if (debug_level >= psb_debug_inner_) then - write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & - &' dim',all_dim(1:np), sum(all_dim) - endif - - ! root has to gather loc_glob from each process - allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) - - else - ! - ! This is to keep debugging compilers from being upset by - ! calling an external MPI function with an unallocated array; - ! the Fortran side would complain even if the MPI side does - ! not use the unallocated stuff. - ! - allocate(l_t_g_all(1),scatterv(1),stat=info) - end if - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='Allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call mpi_gatherv(ltg,nrow,& - & psb_mpi_ipk_integer,l_t_g_all,all_dim,& - & displ,psb_mpi_ipk_integer,rootrank,icomm,info) - - ! prepare vector to scatter - if (iam == iroot) then - do i=1,np - pos=displ(i) - do j=1, all_dim(i) - idx=l_t_g_all(pos+j) - scatterv(pos+j)=globx(idx) - - end do - end do - end if - - call mpi_scatterv(scatterv,all_dim,displ,& - & psb_mpi_c_dpk_,locx,nrow,& - & psb_mpi_c_dpk_,rootrank,icomm,info) - - deallocate(l_t_g_all, scatterv,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - - deallocate(all_dim, displ, ltg,stat=info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ione*ictxt,err_act) - - return - -end subroutine psb_zscatterv - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ subroutine psb_zscatter_vect(globx, locx, desc_a, info, root, mold) use psb_base_mod, psb_protect_name => psb_zscatter_vect implicit none @@ -504,7 +54,7 @@ subroutine psb_zscatter_vect(globx, locx, desc_a, info, root, mold) class(psb_z_base_vect_type), intent(in), optional :: mold ! locals - integer(psb_mpik_) :: ictxt, np, me, icomm, myrank, rootrank + integer(psb_mpk_) :: ictxt, np, me, icomm, myrank, rootrank integer(psb_ipk_) :: ierr(5), err_act, m, n, i, j, idx, nrow, iglobx, jglobx,& & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx complex(psb_dpk_), allocatable :: vlocx(:) @@ -512,9 +62,11 @@ subroutine psb_zscatter_vect(globx, locx, desc_a, info, root, mold) integer(psb_ipk_) :: debug_level, debug_unit name='psb_scatter_vect' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/comm/psb_zscatter_a.F90 b/base/comm/psb_zscatter_a.F90 new file mode 100644 index 000000000..557166d80 --- /dev/null +++ b/base/comm/psb_zscatter_a.F90 @@ -0,0 +1,480 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zscatter.f90 +! +! Subroutine: psb_zscatterm +! This subroutine scatters a global matrix locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - complex,dimension(:,:). The global matrix to scatter. +! locx - complex,dimension(:,:). The local piece of the distributed matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Error code. +! iroot - integer(optional). The process that owns the global matrix. +! If -1 all the processes have a copy. +! Default -1 +subroutine psb_zscatterm(globx, locx, desc_a, info, root) + + use psb_base_mod, psb_protect_name => psb_zscatterm +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + complex(psb_dpk_), intent(out), allocatable :: locx(:,:) + complex(psb_dpk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, me, iroot, icomm, myrank, rootrank, iam, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, lock, globk, k, maxk, & + & col,pos + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + complex(psb_dpk_),allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + + name='psb_scatterm' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot >= np)) then + info=psb_err_input_value_invalid_i_ + ierr(1)=5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + iglobx = 1 + jglobx = 1 + lda_globx = size(globx,1) + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,me) + + if (iroot==-1) then + lda_globx = size(globx, 1) + k = size(globx,2) + else + if (iam==iroot) then + k = size(globx,2) + lda_globx = size(globx, 1) + end if + end if + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow=desc_a%get_local_rows() + ! root has to gather size information + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + + call psb_geall(locx,desc_a,info,n=k) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do j=1,k + do i=1, nrow + locx(i,j)=globx(ltg(i),j) + end do + end do + else + + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if (iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1)+all_dim(i-1) + end do + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + do col=1, k + ! prepare vector to scatter + if(iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx,col) + end do + end do + end if + + ! scatter + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_c_dpk_,locx(1,col),nrow,& + & psb_mpi_c_dpk_,rootrank,icomm,info) + + end do + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + end if + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_zscatterm + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ + +! Subroutine: psb_zscatterv +! This subroutine scatters a global vector locally owned by one process +! into pieces that are local to alle the processes. +! +! Arguments: +! globx - complex,dimension(:). The global vector to scatter. +! locx - complex,dimension(:). The local piece of the ditributed vector. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +! iroot - integer(optional). The process that owns the global vector. If -1 all +! the processes have a copy. +! +subroutine psb_zscatterv(globx, locx, desc_a, info, root) + use psb_base_mod, psb_protect_name => psb_zscatterv +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + + complex(psb_dpk_), intent(out), allocatable :: locx(:) + complex(psb_dpk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + + + ! locals + integer(psb_mpk_) :: ictxt, np, iam, iroot, iiroot, icomm, myrank, rootrank, nlr + integer(psb_ipk_) :: ierr(5), err_act, nrow,& + & ilocx, jlocx, lda_locx, lda_globx, k, pos, ilx, jlx + integer(psb_lpk_) :: m, n, i, j, idx, iglobx, jglobx + complex(psb_dpk_), allocatable :: scatterv(:) + integer(psb_mpk_), allocatable :: displ(:), all_dim(:) + integer(psb_lpk_), allocatable :: l_t_g_all(:), ltg(:) + character(len=20) :: name, ch_err + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_scatterv' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt=desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + ! check on blacs grid + call psb_info(ictxt, iam, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(root)) then + iroot = root + if((iroot < -1).or.(iroot > np)) then + info=psb_err_input_value_invalid_i_ + ierr(1) = 5; ierr(2)=iroot + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + else + iroot = psb_root_ + end if + + call psb_get_mpicomm(ictxt,icomm) + call psb_get_rank(myrank,ictxt,iam) + + iglobx = 1 + jglobx = 1 + ilocx = 1 + jlocx = 1 + if ((iroot==-1).or.(iam==iroot))& + & lda_globx = size(globx, 1) + + + m = desc_a%get_global_rows() + n = desc_a%get_global_cols() + + k = 1 + ! there should be a global check on k here!!! + if ((iroot==-1).or.(iam==iroot)) & + & call psb_chkglobvect(m,n,lda_globx,iglobx,jglobx,desc_a,info) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chk(glob)vect' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + allocate(displ(np),all_dim(np),ltg(nrow),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + do i=1, nrow + ltg(i) = i + end do + call psb_loc_to_glob(ltg(1:nrow),desc_a,info) + call psb_geall(locx,desc_a,info) + + if ((iroot == -1).or.(np == 1)) then + ! extract my chunk + do i=1, nrow + locx(i)=globx(ltg(i)) + end do + else + call psb_get_rank(rootrank,ictxt,iroot) + ! + ! This is potentially unsafe when IPK=8 + ! But then, IPK=8 is highly experimental anyway. + ! + nlr = nrow + call mpi_gather(nlr,1,psb_mpi_mpk_,all_dim,& + & 1,psb_mpi_mpk_,rootrank,icomm,info) + + if(iam == iroot) then + displ(1)=0 + do i=2,np + displ(i)=displ(i-1) + all_dim(i-1) + end do + if (debug_level >= psb_debug_inner_) then + write(debug_unit,*) iam,' ',trim(name),' displ:',displ(1:np), & + &' dim',all_dim(1:np), sum(all_dim) + endif + + ! root has to gather loc_glob from each process + allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info) + + else + ! + ! This is to keep debugging compilers from being upset by + ! calling an external MPI function with an unallocated array; + ! the Fortran side would complain even if the MPI side does + ! not use the unallocated stuff. + ! + allocate(l_t_g_all(1),scatterv(1),stat=info) + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call mpi_gatherv(ltg,nlr,& + & psb_mpi_lpk_,l_t_g_all,all_dim,& + & displ,psb_mpi_lpk_,rootrank,icomm,info) + + ! prepare vector to scatter + if (iam == iroot) then + do i=1,np + pos=displ(i) + do j=1, all_dim(i) + idx=l_t_g_all(pos+j) + scatterv(pos+j)=globx(idx) + + end do + end do + end if + + call mpi_scatterv(scatterv,all_dim,displ,& + & psb_mpi_c_dpk_,locx,nrow,& + & psb_mpi_c_dpk_,rootrank,icomm,info) + + deallocate(l_t_g_all, scatterv,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + + deallocate(all_dim, displ, ltg,stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_zscatterv + diff --git a/base/comm/psb_zspgather.F90 b/base/comm/psb_zspgather.F90 index 0505420de..fbcae1f33 100644 --- a/base/comm/psb_zspgather.F90 +++ b/base/comm/psb_zspgather.F90 @@ -31,6 +31,9 @@ ! ! File: psb_zspgather.f90 subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif use psb_desc_mod use psb_error_mod use psb_penv_mod @@ -51,21 +54,183 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep logical, intent(in), optional :: keepnum,keeploc type(psb_z_coo_sparse_mat) :: loc_coo, glob_coo - integer(psb_ipk_) :: err_act, dupl_, nrg, ncg, nzg - integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + integer(psb_ipk_) :: nrg, ncg, nzg, nzl + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k logical :: keepnum_, keeploc_ - integer(psb_mpik_) :: ictxt,np,me - integer(psb_mpik_) :: icomm, minfo, ndx - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: locia(:), locja(:), glbia(:), glbja(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name integer(psb_ipk_) :: debug_level, debug_unit name='psb_gather' - if (psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + ierr(1) = 2*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_realloc(nzl,locia,info) + call psb_realloc(nzl,locja,info) + call psb_loc_to_glob(loc_coo%ia(1:nzl),locia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),locja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + nzg = sum(nzbr) + if (nzg <0) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if (nrg > HUGE(1_psb_mpk_)) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + + if (info == psb_success_) call psb_realloc(nzg,glbia,info) + if (info == psb_success_) call psb_realloc(nzg,glbja,info) + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_dpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locia,ndx,psb_mpi_lpk_,& + & glbia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(locja,ndx,psb_mpi_lpk_,& + & glbja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + deallocate(locia,locja, stat=info) + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + glob_coo%ia(1:nzg) = glbia(1:nzg) + glob_coo%ja(1:nzg) = glbja(1:nzg) + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + deallocate(glbia,glbja, stat=info) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_zsp_allgather + + +subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_zspmat_type), intent(inout) :: loca + type(psb_lzspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_lz_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_ipk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() icomm = desc_a%get_mpic() call psb_info(ictxt, me, np) @@ -86,10 +251,9 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nrg = desc_a%get_global_rows() ncg = desc_a%get_global_rows() - allocate(nzbr(np), idisp(np),stat=info) + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) if (info /= psb_success_) then - info=psb_err_alloc_request_ - ierr(1) = 2*np + info=psb_err_alloc_request_; ierr(1) = 3*np call psb_errpush(info,name,i_err=ierr,a_err='integer') goto 9999 end if @@ -106,9 +270,25 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep nzbr(:) = 0 nzbr(me+1) = nzl call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) if (info /= psb_success_) goto 9999 + ! + ! PLS REVIEW AND ADD OVERFLOW ERROR CHECKING + ! + do ip=1,np idisp(ip) = sum(nzbr(1:ip-1)) enddo @@ -117,21 +297,168 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep & glob_coo%val,nzbr,idisp,& & psb_mpi_c_dpk_,icomm,minfo) if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_ipk_integer,& + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& & glob_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) + & psb_mpi_lpk_,icomm,minfo) if (minfo == psb_success_) call & - & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_ipk_integer,& + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& & glob_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) + & psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then info = minfo call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') goto 9999 - end if - + end if call loc_coo%free() + ! + ! Is the code below safe? For very large cases + ! the indices in glob_coo will overflow. But then, + ! for very large cases it does not make sense to + ! gather the matrix on a single procecss anyway... + ! + call glob_coo%set_nzeros(nzg) + if (present(dupl)) call glob_coo%set_dupl(dupl) + call globa%mv_from(glob_coo) + + else + write(psb_err_unit,*) 'SP_ALLGATHER: Not implemented yet with keepnum ',keepnum_ + info = -1 + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_error_handler(ione*ictxt,err_act) + + return + +end subroutine psb_lzsp_allgather + +subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) +#if defined(HAVE_ISO_FORTRAN_ENV) + use iso_fortran_env +#endif + use psb_desc_mod + use psb_error_mod + use psb_penv_mod + use psb_mat_mod + use psb_tools_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + type(psb_lzspmat_type), intent(inout) :: loca + type(psb_lzspmat_type), intent(inout) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root, dupl + logical, intent(in), optional :: keepnum,keeploc + + type(psb_lz_coo_sparse_mat) :: loc_coo, glob_coo + integer(psb_lpk_) :: nrg, ncg, nzg + integer(psb_ipk_) :: err_act, dupl_ + integer(psb_lpk_) :: ip,naggrm1,naggrp1, i, j, k, nzl + logical :: keepnum_, keeploc_ + integer(psb_mpk_) :: ictxt,np,me + integer(psb_mpk_) :: icomm, minfo, ndx + integer(psb_mpk_), allocatable :: nzbr(:), idisp(:) + integer(psb_lpk_), allocatable :: lnzbr(:) + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + integer(psb_ipk_) :: debug_level, debug_unit + + name='psb_gather' + info=psb_success_ + + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + call psb_info(ictxt, me, np) + + if (present(keepnum)) then + keepnum_ = keepnum + else + keepnum_ = .true. + end if + if (present(keeploc)) then + keeploc_ = keeploc + else + keeploc_ = .true. + end if + call globa%free() + + if (keepnum_) then + nrg = desc_a%get_global_rows() + ncg = desc_a%get_global_rows() + + allocate(nzbr(np), idisp(np),lnzbr(np),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1) = 3*np + call psb_errpush(info,name,i_err=ierr,a_err='integer') + goto 9999 + end if + + + if (keeploc_) then + call loca%cp_to(loc_coo) + else + call loca%mv_to(loc_coo) + end if + nzl = loc_coo%get_nzeros() + call psb_loc_to_glob(loc_coo%ia(1:nzl),desc_a,info,iact='I') + call psb_loc_to_glob(loc_coo%ja(1:nzl),desc_a,info,iact='I') + nzbr(:) = 0 + nzbr(me+1) = nzl + call psb_sum(ictxt,nzbr(1:np)) + lnzbr = nzbr + nzg = sum(nzbr) + if ((nzg < 0).or.(nzg /= sum(lnzbr))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#if defined(HAVE_ISO_FORTRAN_ENV) + if ((nrg > HUGE(1_psb_mpk_)).or.(nzg > HUGE(1_psb_mpk_))& + & .or.(sum(lnzbr) > HUGE(1_psb_mpk_))) then + info = psb_err_mpi_int_ovflw_ + call psb_errpush(info,name); goto 9999 + end if +#endif + if (info == psb_success_) call glob_coo%allocate(nrg,ncg,nzg) + if (info /= psb_success_) goto 9999 + + do ip=1,np + idisp(ip) = sum(nzbr(1:ip-1)) + enddo + ndx = nzbr(me+1) + call mpi_allgatherv(loc_coo%val,ndx,psb_mpi_c_dpk_,& + & glob_coo%val,nzbr,idisp,& + & psb_mpi_c_dpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ia,ndx,psb_mpi_lpk_,& + & glob_coo%ia,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + if (minfo == psb_success_) call & + & mpi_allgatherv(loc_coo%ja,ndx,psb_mpi_lpk_,& + & glob_coo%ja,nzbr,idisp,& + & psb_mpi_lpk_,icomm,minfo) + + if (minfo /= psb_success_) then + info = minfo + call psb_errpush(psb_err_internal_error_,name,a_err=' from mpi_allgatherv') + goto 9999 + end if + call loc_coo%free() + ! call glob_coo%set_nzeros(nzg) if (present(dupl)) call glob_coo%set_dupl(dupl) call globa%mv_from(glob_coo) @@ -153,4 +480,4 @@ subroutine psb_zsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keep return -end subroutine psb_zsp_allgather +end subroutine psb_lzlzsp_allgather diff --git a/base/internals/psb_indx_map_fnd_owner.F90 b/base/internals/psb_indx_map_fnd_owner.F90 index fa439062e..b6b870fa0 100644 --- a/base/internals/psb_indx_map_fnd_owner.F90 +++ b/base/internals/psb_indx_map_fnd_owner.F90 @@ -60,19 +60,20 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) #ifdef MPI_H include 'mpif.h' #endif - integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_indx_map), intent(in) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), allocatable :: helem(:),hproc(:),& - & answers(:,:),idxsrch(:,:), hhidx(:) - integer(psb_mpik_), allocatable :: hsz(:),hidx(:), & + integer(psb_lpk_), allocatable :: answers(:,:), idxsrch(:,:), hproc(:) + integer(psb_ipk_), allocatable :: helem(:), hhidx(:) + integer(psb_mpk_), allocatable :: hsz(:),hidx(:), & & sdsz(:),sdidx(:), rvsz(:), rvidx(:) - integer(psb_mpik_) :: icomm, minfo, iictxt - integer(psb_ipk_) :: i,n_row,n_col,err_act,ih,hsize,ip,isz,k,j,& - & last_ih, last_j, nv, mglob + integer(psb_mpk_) :: icomm, minfo, iictxt + integer(psb_ipk_) :: i,n_row,n_col,err_act,hsize,ip,isz,j, k,& + & last_ih, last_j, nv + integer(psb_lpk_) :: mglob, ih integer(psb_ipk_) :: ictxt,np,me, nresp logical, parameter :: gettime=.false. real(psb_dpk_) :: t0, t1, t2, t3, t4, tamx, tidx @@ -169,8 +170,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) t3 = psb_wtime() end if - call mpi_allgatherv(idx,hsz(me+1),psb_mpi_ipk_integer,& - & hproc,hsz,hidx,psb_mpi_ipk_integer,& + call mpi_allgatherv(idx,hsz(me+1),psb_mpi_lpk_,& + & hproc,hsz,hidx,psb_mpi_lpk_,& & icomm,minfo) if (gettime) then tamx = psb_wtime() - t3 @@ -213,8 +214,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) end if ! Collect all the answers with alltoallv (need sizes) - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& - & rvsz,1,psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) isz = sum(rvsz) @@ -228,8 +229,8 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) rvidx(ip) = j j = j + rvsz(ip) end do - call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_ipk_integer,& - & answers(:,1),rvsz,rvidx,psb_mpi_ipk_integer,& + call mpi_alltoallv(hproc,sdsz,sdidx,psb_mpi_lpk_,& + & answers(:,1),rvsz,rvidx,psb_mpi_lpk_,& & icomm,minfo) if (gettime) then tamx = psb_wtime() - t3 + tamx @@ -261,19 +262,20 @@ subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) do if (j > size(answers,1)) then ! Last resort attempt. - j = psb_ibsrch(ih,size(answers,1,kind=psb_ipk_),answers(:,1)) + j = psb_bsrch(ih,size(answers,1,kind=psb_ipk_),answers(:,1)) if (j == -1) then write(psb_err_unit,*) me,'psi_fnd_owner: searching for ',ih, & & 'not found : ',size(answers,1),':',answers(:,1) info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='out bounds srch ih') + call psb_errpush(psb_err_internal_error_,& + & name,a_err='out bounds srch ih') goto 9999 end if end if if (answers(j,1) == ih) exit if (answers(j,1) > ih) then k = j - j = psb_ibsrch(ih,k,answers(1:k,1)) + j = psb_bsrch(ih,k,answers(1:k,1)) if (j == -1) then write(psb_err_unit,*) me,'psi_fnd_owner: searching for ',ih, & & 'not found : ',size(answers,1),':',answers(:,1) diff --git a/base/internals/psi_bld_tmphalo.f90 b/base/internals/psi_bld_tmphalo.f90 index 158a08930..fd9b7c381 100644 --- a/base/internals/psi_bld_tmphalo.f90 +++ b/base/internals/psi_bld_tmphalo.f90 @@ -56,7 +56,8 @@ subroutine psi_bld_tmphalo(desc,info) type(psb_desc_type), intent(inout) :: desc integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),allocatable :: helem(:),hproc(:) + integer(psb_lpk_),allocatable :: helem(:) + integer(psb_ipk_),allocatable :: hproc(:) integer(psb_ipk_),allocatable :: tmphl(:) integer(psb_ipk_) :: i,j,np,me,lhalo,nhalo,& diff --git a/base/internals/psi_bld_tmpovrl.f90 b/base/internals/psi_bld_tmpovrl.f90 index afe99c8ba..671a20d35 100644 --- a/base/internals/psi_bld_tmpovrl.f90 +++ b/base/internals/psi_bld_tmpovrl.f90 @@ -50,14 +50,14 @@ ! desc - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! -subroutine psi_bld_tmpovrl(iv,desc,info) +subroutine psi_i_bld_tmpovrl(iv,desc,info) use psb_desc_mod use psb_serial_mod use psb_const_mod use psb_error_mod use psb_penv_mod use psb_realloc_mod - use psi_mod, psb_protect_name => psi_bld_tmpovrl + use psi_mod, psb_protect_name => psi_i_bld_tmpovrl implicit none integer(psb_ipk_), intent(in) :: iv(:) type(psb_desc_type), intent(inout) :: desc @@ -65,7 +65,8 @@ subroutine psi_bld_tmpovrl(iv,desc,info) !locals integer(psb_ipk_) :: counter,i,j,np,me,loc_row,err,loc_col,nprocs,& - & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, icomm + & l_ov_ix,l_ov_el, err_act, itmpov, k, glx, icomm + integer(psb_ipk_) :: idx integer(psb_ipk_), allocatable :: ov_idx(:),ov_el(:,:) integer(psb_ipk_) :: ictxt,n_row, debug_unit, debug_level @@ -145,6 +146,6 @@ subroutine psi_bld_tmpovrl(iv,desc,info) 9999 call psb_error_handler(ictxt,err_act) - return + return -end subroutine psi_bld_tmpovrl +end subroutine psi_i_bld_tmpovrl diff --git a/base/internals/psi_crea_bnd_elem.f90 b/base/internals/psi_crea_bnd_elem.f90 index 92e7c86ad..d537dc296 100644 --- a/base/internals/psi_crea_bnd_elem.f90 +++ b/base/internals/psi_crea_bnd_elem.f90 @@ -30,9 +30,9 @@ ! ! ! -! File: psi_crea_bnd_elem.f90 +! File: psi_i_crea_bnd_elem.f90 ! -! Subroutine: psi_crea_bnd_elem +! Subroutine: psi_i_crea_bnd_elem ! Extracts a list of boundary indices. If no boundary is present in ! the distribution the output vector is put in the unallocated state, ! otherwise its size is equal to the number of boundary indices on the @@ -43,8 +43,8 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! -subroutine psi_crea_bnd_elem(bndel,desc_a,info) - use psi_mod, psb_protect_name => psi_crea_bnd_elem +subroutine psi_i_crea_bnd_elem(bndel,desc_a,info) + use psi_mod, psb_protect_name => psi_i_crea_bnd_elem use psb_realloc_mod use psb_desc_mod use psb_error_mod @@ -85,28 +85,19 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info) call psb_msort_unique(work(1:i),j) - if (.true.) then - if (j>=0) then - call psb_realloc(j,bndel,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - bndel(1:j) = work(1:j) - else - if (allocated(bndel)) then - deallocate(bndel) - end if - end if - else - call psb_realloc(j+1,bndel,info) + + if (j>=0) then + call psb_realloc(j,bndel,info) if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') goto 9999 end if bndel(1:j) = work(1:j) - bndel(j+1) = -1 - endif + else + if (allocated(bndel)) then + deallocate(bndel) + end if + end if deallocate(work) call psb_erractionrestore(err_act) @@ -116,4 +107,4 @@ subroutine psi_crea_bnd_elem(bndel,desc_a,info) return -end subroutine psi_crea_bnd_elem +end subroutine psi_i_crea_bnd_elem diff --git a/base/internals/psi_crea_index.f90 b/base/internals/psi_crea_index.f90 index 6c88ae2d5..56be421eb 100644 --- a/base/internals/psi_crea_index.f90 +++ b/base/internals/psi_crea_index.f90 @@ -31,7 +31,7 @@ ! ! ! -! File: psi_crea_index.f90 +! File: psi_i_crea_index.f90 ! ! Subroutine: psb_crea_index ! Converts a list of data exchanges from build format to assembled format. @@ -49,12 +49,12 @@ ! nrcv - integer Total receive buffer size on the calling process ! ! -subroutine psi_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) +subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) use psb_realloc_mod use psb_desc_mod use psb_error_mod use psb_penv_mod - use psi_mod, psb_protect_name => psi_crea_index + use psi_mod, psb_protect_name => psi_i_crea_index implicit none type(psb_desc_type), intent(in) :: desc_a @@ -150,4 +150,4 @@ subroutine psi_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) 9999 call psb_error_handler(ictxt,err_act) return -end subroutine psi_crea_index +end subroutine psi_i_crea_index diff --git a/base/internals/psi_crea_ovr_elem.f90 b/base/internals/psi_crea_ovr_elem.f90 index 9fd69247a..359c264c3 100644 --- a/base/internals/psi_crea_ovr_elem.f90 +++ b/base/internals/psi_crea_ovr_elem.f90 @@ -30,9 +30,9 @@ ! ! ! -! File: psi_crea_ovr_elem.f90 +! File: psi_i_crea_ovr_elem.f90 ! -! Subroutine: psi_crea_ovr_elem +! Subroutine: psi_i_crea_ovr_elem ! Creates the overlap_elem list: for each overlap index, store the index and ! the number of processes sharing it (minimum: 2). List is ended by -1. ! See also description in base/modules/psb_desc_type.f90 @@ -42,9 +42,9 @@ ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code. ! -subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info) +subroutine psi_i_crea_ovr_elem(me,desc_overlap,ovr_elem,info) - use psi_mod, psb_protect_name => psi_crea_ovr_elem + use psi_mod, psb_protect_name => psi_i_crea_ovr_elem use psb_realloc_mod use psb_error_mod use psb_penv_mod @@ -139,4 +139,4 @@ subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info) return -end subroutine psi_crea_ovr_elem +end subroutine psi_i_crea_ovr_elem diff --git a/base/internals/psi_desc_impl.f90 b/base/internals/psi_desc_impl.f90 index 977af721c..6cd294f8d 100644 --- a/base/internals/psi_desc_impl.f90 +++ b/base/internals/psi_desc_impl.f90 @@ -60,16 +60,16 @@ subroutine psi_renum_index(iperm,idx,info) end subroutine psi_renum_index -subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) +subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) - use psi_mod, psi_protect_name => psi_cnv_dsc + use psi_mod, psi_protect_name => psi_i_cnv_dsc use psb_realloc_mod implicit none ! ....scalars parameters.... - integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) + integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) type(psb_desc_type), intent(inout) :: cdesc - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info class(psb_i_base_vect_type), optional, intent(in) :: mold ! ....local scalars.... @@ -185,11 +185,11 @@ subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) return -end subroutine psi_cnv_dsc +end subroutine psi_i_cnv_dsc -subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) - use psi_mod, psi_protect_name => psi_inner_cnvs +subroutine psi_i_inner_cnvs(x,hashmask,hashv,glb_lc) + use psi_mod, psi_protect_name => psi_i_inner_cnvs integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) integer(psb_ipk_), intent(inout) :: x @@ -231,10 +231,10 @@ subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) else x = tmp end if -end subroutine psi_inner_cnvs +end subroutine psi_i_inner_cnvs -subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc) - use psi_mod, psi_protect_name => psi_inner_cnvs2 +subroutine psi_i_inner_cnvs2(x,y,hashmask,hashv,glb_lc) + use psi_mod, psi_protect_name => psi_i_inner_cnvs2 integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) integer(psb_ipk_), intent(in) :: x integer(psb_ipk_), intent(out) :: y @@ -276,11 +276,11 @@ subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc) else y = tmp end if -end subroutine psi_inner_cnvs2 +end subroutine psi_i_inner_cnvs2 -subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) - use psi_mod, psi_protect_name => psi_inner_cnv1 +subroutine psi_i_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) + use psi_mod, psi_protect_name => psi_i_inner_cnv1 integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(inout) :: x(:) @@ -358,10 +358,10 @@ subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) end if end do end if -end subroutine psi_inner_cnv1 +end subroutine psi_i_inner_cnv1 -subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) - use psi_mod, psi_protect_name => psi_inner_cnv2 +subroutine psi_i_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) + use psi_mod, psi_protect_name => psi_i_inner_cnv2 integer(psb_ipk_), intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) logical, intent(in),optional :: mask(:) integer(psb_ipk_), intent(in) :: x(:) @@ -446,10 +446,10 @@ subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) end if end do end if -end subroutine psi_inner_cnv2 +end subroutine psi_i_inner_cnv2 -subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) - use psi_mod, psi_protect_name => psi_bld_ovr_mst +subroutine psi_i_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) + use psi_mod, psi_protect_name => psi_i_bld_ovr_mst use psb_realloc_mod implicit none @@ -493,5 +493,5 @@ subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) return -end subroutine psi_bld_ovr_mst +end subroutine psi_i_bld_ovr_mst diff --git a/base/internals/psi_desc_index.F90 b/base/internals/psi_desc_index.F90 index e5a890f40..7f36c6ea5 100644 --- a/base/internals/psi_desc_index.F90 +++ b/base/internals/psi_desc_index.F90 @@ -95,7 +95,7 @@ ! is rebuilt during the CDASB process (in the psi_ldsc_pre_halo subroutine). ! ! -subroutine psi_desc_index(desc,index_in,dep_list,& +subroutine psi_i_desc_index(desc,index_in,dep_list,& & length_dl,nsnd,nrcv,desc_index,info) use psb_desc_mod use psb_realloc_mod @@ -105,7 +105,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,& use mpi #endif use psb_penv_mod - use psi_mod, psb_protect_name => psi_desc_index + use psi_mod, psb_protect_name => psi_i_desc_index implicit none #ifdef MPI_H include 'mpif.h' @@ -113,7 +113,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& ! ...array parameters..... type(psb_desc_type) :: desc - integer(psb_ipk_) :: index_in(:),dep_list(:) + integer(psb_ipk_) :: index_in(:) + integer(psb_ipk_) :: dep_list(:) integer(psb_ipk_),allocatable :: desc_index(:) integer(psb_ipk_) :: length_dl,nsnd,nrcv,info ! ....local scalars... @@ -122,14 +123,14 @@ subroutine psi_desc_index(desc,index_in,dep_list,& integer(psb_ipk_) :: ictxt integer(psb_ipk_), parameter :: no_comm=-1 ! ...local arrays.. - integer(psb_ipk_),allocatable :: sndbuf(:), rcvbuf(:) + integer(psb_lpk_),allocatable :: sndbuf(:), rcvbuf(:) - integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:),& + integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:),& & bsdindx(:),sdsz(:) integer(psb_ipk_) :: ihinsz,ntot,k,err_act,nidx,& & idxr, idxs, iszs, iszr, nesd, nerv - integer(psb_mpik_) :: icomm, minfo + integer(psb_mpk_) :: icomm, minfo logical,parameter :: usempi=.true. integer(psb_ipk_) :: debug_level, debug_unit @@ -182,7 +183,7 @@ subroutine psi_desc_index(desc,index_in,dep_list,& i = i + nerv + 1 end do ihinsz=i - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1,psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,rvsz,1,psb_mpi_mpk_,icomm,minfo) if (minfo /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoall') goto 9999 @@ -281,8 +282,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,& idxr = idxr + rvsz(proc+1) end do - call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_ipk_integer,& - & rcvbuf,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(sndbuf,sdsz,bsdindx,psb_mpi_lpk_,& + & rcvbuf,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='mpi_alltoallv') goto 9999 @@ -301,7 +302,6 @@ subroutine psi_desc_index(desc,index_in,dep_list,& desc_index(i) = nerv call desc%indxmap%g2l(sndbuf(bsdindx(proc+1)+1:bsdindx(proc+1)+nerv),& & desc_index(i+1:i+nerv),info) - i = i + nerv + 1 nesd = rvsz(proc+1) desc_index(i) = nesd @@ -330,4 +330,4 @@ subroutine psi_desc_index(desc,index_in,dep_list,& return -end subroutine psi_desc_index +end subroutine psi_i_desc_index diff --git a/base/internals/psi_dl_check.f90 b/base/internals/psi_dl_check.f90 index d20ac13e7..8b12f0239 100644 --- a/base/internals/psi_dl_check.f90 +++ b/base/internals/psi_dl_check.f90 @@ -44,9 +44,9 @@ ! length_dl(:) - integer Items in dependency lists; updated on ! exit ! -subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) +subroutine psi_i_dl_check(dep_list,dl_lda,np,length_dl) - use psi_mod, psb_protect_name => psi_dl_check + use psi_mod, psb_protect_name => psi_i_dl_check use psb_const_mod use psb_desc_mod implicit none @@ -92,4 +92,4 @@ subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) enddo outer enddo -end subroutine psi_dl_check +end subroutine psi_i_dl_check diff --git a/base/internals/psi_extrct_dl.F90 b/base/internals/psi_extrct_dl.F90 index cc6d8bb69..5edbd9ad4 100644 --- a/base/internals/psi_extrct_dl.F90 +++ b/base/internals/psi_extrct_dl.F90 @@ -29,7 +29,7 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& +subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& & length_dl,np,dl_lda,mode,info) ! internal routine @@ -118,7 +118,7 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& ! desc_str list. ! length_dl integer array(0:np) ! length_dl(i) is the length of dep_list(*,i) list - use psi_mod, psb_protect_name => psi_extract_dep_list + use psi_mod, psb_protect_name => psi_i_extract_dep_list #ifdef MPI_MOD use mpi #endif @@ -136,7 +136,8 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& integer(psb_ipk_) :: np,dl_lda,mode, info ! ....array parameters.... - integer(psb_ipk_) :: desc_str(*),dep_list(dl_lda,0:np),length_dl(0:np) + integer(psb_ipk_) :: desc_str(*) + integer(psb_ipk_) :: dep_list(dl_lda,0:np),length_dl(0:np) integer(psb_ipk_), allocatable :: itmp(:) ! .....local arrays.... integer(psb_ipk_) :: int_err(5) @@ -145,7 +146,7 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& integer(psb_ipk_) :: i,pointer_dep_list,proc,j,err_act integer(psb_ipk_) :: err integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpik_) :: iictxt, icomm, me, npr, dl_mpi, minfo + integer(psb_mpk_) :: iictxt, icomm, me, npr, dl_mpi, minfo character name*20 name='psi_extrct_dl' @@ -272,8 +273,8 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& endif itmp(1:dl_lda) = dep_list(1:dl_lda,me) dl_mpi = dl_lda - call mpi_allgather(itmp,dl_mpi,psb_mpi_ipk_integer,& - & dep_list,dl_mpi,psb_mpi_ipk_integer,icomm,minfo) + call mpi_allgather(itmp,dl_mpi,psb_mpi_ipk_,& + & dep_list,dl_mpi,psb_mpi_ipk_,icomm,minfo) info = minfo if (info == 0) deallocate(itmp,stat=info) if (info /= psb_success_) then @@ -292,4 +293,4 @@ subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& return -end subroutine psi_extract_dep_list +end subroutine psi_i_extract_dep_list diff --git a/base/internals/psi_fnd_owner.F90 b/base/internals/psi_fnd_owner.F90 index 3fe9d3b31..456dd4d4b 100644 --- a/base/internals/psi_fnd_owner.F90 +++ b/base/internals/psi_fnd_owner.F90 @@ -63,7 +63,7 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info) include 'mpif.h' #endif integer(psb_ipk_), intent(in) :: nv - integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) type(psb_desc_type), intent(in) :: desc integer(psb_ipk_), intent(out) :: info diff --git a/base/internals/psi_sort_dl.f90 b/base/internals/psi_sort_dl.f90 index 002d3584b..4c2b78db1 100644 --- a/base/internals/psi_sort_dl.f90 +++ b/base/internals/psi_sort_dl.f90 @@ -29,12 +29,12 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_sort_dl(dep_list,l_dep_list,np,info) +subroutine psi_i_sort_dl(dep_list,l_dep_list,np,info) ! ! interface between former sort_dep_list subroutine ! and new srtlist ! - use psi_mod, psb_protect_name => psi_sort_dl + use psi_mod, psb_protect_name => psi_i_sort_dl use psb_const_mod use psb_error_mod implicit none @@ -87,7 +87,7 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info) return -end subroutine psi_sort_dl +end subroutine psi_i_sort_dl diff --git a/base/modules/Makefile b/base/modules/Makefile index c668a58fe..65e8d7f06 100644 --- a/base/modules/Makefile +++ b/base/modules/Makefile @@ -1,40 +1,107 @@ include ../../Make.inc -BASIC_MODS= psb_const_mod.o psb_error_mod.o psb_realloc_mod.o -COMMINT=psi_comm_buffers_mod.o psi_penv_mod.o psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o -UTIL_MODS = aux/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ +BASIC_MODS= psb_const_mod.o psb_cbind_const_mod.o psb_error_mod.o psb_realloc_mod.o \ + auxil/psb_m_realloc_mod.o \ + auxil/psb_e_realloc_mod.o \ + auxil/psb_s_realloc_mod.o \ + auxil/psb_d_realloc_mod.o \ + auxil/psb_c_realloc_mod.o \ + auxil/psb_z_realloc_mod.o + +COMMINT=penv/psi_comm_buffers_mod.o penv/psi_penv_mod.o \ + penv/psi_p2p_mod.o penv/psi_m_p2p_mod.o \ + penv/psi_e_p2p_mod.o \ + penv/psi_s_p2p_mod.o \ + penv/psi_d_p2p_mod.o \ + penv/psi_c_p2p_mod.o \ + penv/psi_z_p2p_mod.o \ + penv/psi_collective_mod.o \ + penv/psi_e_collective_mod.o \ + penv/psi_m_collective_mod.o \ + penv/psi_s_collective_mod.o \ + penv/psi_d_collective_mod.o \ + penv/psi_c_collective_mod.o \ + penv/psi_z_collective_mod.o + +UTIL_MODS = auxil/psb_string_mod.o desc/psb_desc_const_mod.o desc/psb_indx_map_mod.o\ desc/psb_gen_block_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o\ - desc/psb_glist_map_mod.o desc/psb_hash_map_mod.o \ - desc/psb_desc_mod.o aux/psb_sort_mod.o \ - serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o \ + desc/psb_glist_map_mod.o desc/psb_hash_map_mod.o desc/psb_hashval.o \ + desc/psb_desc_mod.o auxil/psb_sort_mod.o \ + serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o \ + serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o \ serial/psb_serial_mod.o \ - tools/psb_cd_tools_mod.o tools/psb_i_tools_mod.o tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ - tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o tools/psb_tools_mod.o \ + tools/psb_cd_tools_mod.o \ + tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ + tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ + tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ + tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ + tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ + tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o \ + tools/psb_tools_mod.o \ psb_penv_mod.o $(COMMINT) psb_error_impl.o \ comm/psb_base_linmap_mod.o comm/psb_linmap_mod.o \ - comm/psb_s_linmap_mod.o comm/psb_d_linmap_mod.o comm/psb_c_linmap_mod.o comm/psb_z_linmap_mod.o \ - comm/psb_comm_mod.o comm/psb_i_comm_mod.o comm/psb_s_comm_mod.o comm/psb_d_comm_mod.o\ + comm/psb_s_linmap_mod.o comm/psb_d_linmap_mod.o \ + comm/psb_c_linmap_mod.o comm/psb_z_linmap_mod.o \ + comm/psb_comm_mod.o \ + comm/psb_i_comm_mod.o comm/psb_l_comm_mod.o \ + comm/psb_s_comm_mod.o comm/psb_d_comm_mod.o\ comm/psb_c_comm_mod.o comm/psb_z_comm_mod.o \ - psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o \ - psblas/psb_d_psblas_mod.o psblas/psb_z_psblas_mod.o psblas/psb_psblas_mod.o \ - aux/psi_serial_mod.o aux/psi_i_serial_mod.o \ - aux/psi_s_serial_mod.o aux/psi_d_serial_mod.o aux/psi_c_serial_mod.o aux/psi_z_serial_mod.o \ - psi_mod.o psi_i_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o\ - aux/psb_ip_reord_mod.o\ - aux/psb_i_sort_mod.o aux/psb_s_sort_mod.o aux/psb_d_sort_mod.o \ - aux/psb_c_sort_mod.o aux/psb_z_sort_mod.o \ - psb_check_mod.o aux/psb_hash_mod.o aux/psb_hashval.o\ + comm/psb_m_comm_a_mod.o comm/psb_e_comm_a_mod.o \ + comm/psb_s_comm_a_mod.o comm/psb_d_comm_a_mod.o\ + comm/psb_c_comm_a_mod.o comm/psb_z_comm_a_mod.o \ + comm/psi_e_comm_a_mod.o comm/psi_m_comm_a_mod.o \ + comm/psi_s_comm_a_mod.o comm/psi_d_comm_a_mod.o \ + comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o \ + comm/psi_i_comm_v_mod.o comm/psi_l_comm_v_mod.o \ + comm/psi_s_comm_v_mod.o comm/psi_d_comm_v_mod.o \ + comm/psi_c_comm_v_mod.o comm/psi_z_comm_v_mod.o \ serial/psb_i_base_vect_mod.o serial/psb_i_vect_mod.o\ + serial/psb_l_base_vect_mod.o serial/psb_l_vect_mod.o\ serial/psb_d_base_vect_mod.o serial/psb_d_vect_mod.o\ serial/psb_s_base_vect_mod.o serial/psb_s_vect_mod.o\ serial/psb_c_base_vect_mod.o serial/psb_c_vect_mod.o\ serial/psb_z_base_vect_mod.o serial/psb_z_vect_mod.o\ serial/psb_vect_mod.o\ - serial/psb_base_mat_mod.o serial/psb_mat_mod.o\ + psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o \ + psblas/psb_d_psblas_mod.o psblas/psb_z_psblas_mod.o \ + psblas/psb_psblas_mod.o \ + auxil/psi_serial_mod.o auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ + auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o \ + auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o \ + psi_mod.o psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o\ + auxil/psb_ip_reord_mod.o\ + auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ + auxil/psb_s_ip_reord_mod.o auxil/psb_d_ip_reord_mod.o \ + auxil/psb_c_ip_reord_mod.o auxil/psb_z_ip_reord_mod.o \ + auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ + auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ + auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ + auxil/psb_e_msort_mod.o auxil/psb_e_qsort_mod.o \ + auxil/psb_s_hsort_mod.o auxil/psb_s_isort_mod.o \ + auxil/psb_s_msort_mod.o auxil/psb_s_qsort_mod.o \ + auxil/psb_d_hsort_mod.o auxil/psb_d_isort_mod.o \ + auxil/psb_d_msort_mod.o auxil/psb_d_qsort_mod.o \ + auxil/psb_c_hsort_mod.o auxil/psb_c_isort_mod.o \ + auxil/psb_c_msort_mod.o auxil/psb_c_qsort_mod.o \ + auxil/psb_z_hsort_mod.o auxil/psb_z_isort_mod.o \ + auxil/psb_z_msort_mod.o auxil/psb_z_qsort_mod.o \ + auxil/psb_i_hsort_x_mod.o \ + auxil/psb_l_hsort_x_mod.o \ + auxil/psb_s_hsort_x_mod.o \ + auxil/psb_d_hsort_x_mod.o \ + auxil/psb_c_hsort_x_mod.o \ + auxil/psb_z_hsort_x_mod.o \ + psb_check_mod.o desc/psb_hash_mod.o\ + serial/psb_base_mat_mod.o serial/psb_mat_mod.o\ serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_mat_mod.o \ serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_mat_mod.o \ serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_mat_mod.o \ - serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_mat_mod.o + serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_mat_mod.o +#\ +# serial/psb_ls_csr_mat_mod.o serial/psb_ld_csr_mat_mod.o serial/psb_lc_csr_mat_mod.o serial/psb_lz_csr_mat_mod.o +#\ +# serial/psb_ld_base_mat_mod.o serial/psb_lbase_mat_mod.o serial/psb_ld_csc_mat_mod.o serial/psb_ld_csr_mat_mod.o + MODULES=$(BASIC_MODS) $(UTIL_MODS) @@ -53,72 +120,153 @@ $(LIBDIR)/$(LIBNAME): $(MODULES) $(OBJS) $(MPFOBJS) psb_error_mod.o: psb_const_mod.o -psb_realloc_mod.o: psb_error_mod.o +psb_realloc_mod.o \ + auxil/psb_m_realloc_mod.o \ + auxil/psb_e_realloc_mod.o \ + auxil/psb_s_realloc_mod.o \ + auxil/psb_d_realloc_mod.o \ + auxil/psb_c_realloc_mod.o \ + auxil/psb_z_realloc_mod.o: psb_error_mod.o $(UTIL_MODS): $(BASIC_MODS) -psi_penv_mod.o: psi_comm_buffers_mod.o -psi_bcast_mod.o psi_reduce_mod.o psi_p2p_mod.o: psi_penv_mod.o +penv/psi_penv_mod.o: penv/psi_comm_buffers_mod.o serial/psb_vect_mod.o serial/psb_mat_mod.o +penv/psi_collective_mod.o penv/psi_p2p_mod.o: penv/psi_penv_mod.o + +psb_realloc_mod.o: auxil/psb_m_realloc_mod.o \ + auxil/psb_e_realloc_mod.o \ + auxil/psb_s_realloc_mod.o \ + auxil/psb_d_realloc_mod.o \ + auxil/psb_c_realloc_mod.o \ + auxil/psb_z_realloc_mod.o + +penv/psi_p2p_mod.o: penv/psi_m_p2p_mod.o \ + penv/psi_e_p2p_mod.o \ + penv/psi_s_p2p_mod.o \ + penv/psi_d_p2p_mod.o \ + penv/psi_c_p2p_mod.o \ + penv/psi_z_p2p_mod.o +penv/psi_collective_mod.o: penv/psi_e_collective_mod.o \ + penv/psi_m_collective_mod.o \ + penv/psi_s_collective_mod.o \ + penv/psi_d_collective_mod.o \ + penv/psi_c_collective_mod.o \ + penv/psi_z_collective_mod.o + +penv/psi_m_p2p_mod.o penv/psi_e_p2p_mod.o penv/psi_s_p2p_mod.o \ +penv/psi_d_p2p_mod.o penv/psi_c_p2p_mod.o penv/psi_z_p2p_mod.o\ +penv/psi_e_collective_mod.o penv/psi_m_collective_mod.o penv/psi_s_collective_mod.o \ +penv/psi_d_collective_mod.o penv/psi_c_collective_mod.o penv/psi_z_collective_mod.o: penv/psi_penv_mod.o + +auxil/psb_string_mod.o desc/psb_desc_const_mod.o psi_comm_buffers_mod.o: psb_const_mod.o +desc/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o desc/psb_desc_const_mod.o +auxil/psb_i_sort_mod.o auxil/psb_s_sort_mod.o auxil/psb_d_sort_mod.o auxil/psb_c_sort_mod.o auxil/psb_z_sort_mod.o \ +auxil/psb_ip_reord_mod.o auxil/psi_serial_mod.o auxil/psb_sort_mod.o: $(BASIC_MODS) +auxil/psb_sort_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_m_isort_mod.o \ + auxil/psb_m_msort_mod.o auxil/psb_m_qsort_mod.o \ + auxil/psb_e_hsort_mod.o auxil/psb_e_isort_mod.o \ + auxil/psb_e_msort_mod.o auxil/psb_e_qsort_mod.o \ + auxil/psb_s_hsort_mod.o auxil/psb_s_isort_mod.o \ + auxil/psb_s_msort_mod.o auxil/psb_s_qsort_mod.o \ + auxil/psb_d_hsort_mod.o auxil/psb_d_isort_mod.o \ + auxil/psb_d_msort_mod.o auxil/psb_d_qsort_mod.o \ + auxil/psb_c_hsort_mod.o auxil/psb_c_isort_mod.o \ + auxil/psb_c_msort_mod.o auxil/psb_c_qsort_mod.o \ + auxil/psb_z_hsort_mod.o auxil/psb_z_isort_mod.o \ + auxil/psb_z_msort_mod.o auxil/psb_z_qsort_mod.o \ + auxil/psb_i_hsort_x_mod.o \ + auxil/psb_l_hsort_x_mod.o \ + auxil/psb_s_hsort_x_mod.o \ + auxil/psb_d_hsort_x_mod.o \ + auxil/psb_c_hsort_x_mod.o \ + auxil/psb_z_hsort_x_mod.o \ + auxil/psb_ip_reord_mod.o auxil/psi_serial_mod.o -aux/psb_string_mod.o desc/psb_desc_const_mod.o psi_comm_buffers_mod.o: psb_const_mod.o -aux/psb_hash_mod.o: psb_realloc_mod.o psb_const_mod.o -aux/psb_i_sort_mod.o aux/psb_s_sort_mod.o aux/psb_d_sort_mod.o aux/psb_c_sort_mod.o aux/psb_z_sort_mod.o \ -aux/psb_ip_reord_mod.o aux/psi_serial_mod.o aux/psb_sort_mod.o: $(BASIC_MODS) -aux/psb_sort_mod.o: aux/psb_i_sort_mod.o aux/psb_s_sort_mod.o aux/psb_d_sort_mod.o \ - aux/psb_c_sort_mod.o aux/psb_z_sort_mod.o aux/psb_ip_reord_mod.o aux/psi_serial_mod.o -aux/psi_serial_mod.o: aux/psi_i_serial_mod.o \ - aux/psi_s_serial_mod.o aux/psi_d_serial_mod.o aux/psi_c_serial_mod.o aux/psi_z_serial_mod.o -aux/psi_i_serial_mod.o aux/psi_s_serial_mod.o aux/psi_d_serial_mod.o aux/psi_c_serial_mod.o aux/psi_z_serial_mod.o: psb_const_mod.o +auxil/psb_i_hsort_x_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_e_hsort_mod.o +auxil/psb_l_hsort_x_mod.o: auxil/psb_m_hsort_mod.o auxil/psb_e_hsort_mod.o +auxil/psb_s_hsort_x_mod.o: auxil/psb_s_hsort_mod.o +auxil/psb_d_hsort_x_mod.o: auxil/psb_d_hsort_mod.o +auxil/psb_c_hsort_x_mod.o: auxil/psb_c_hsort_mod.o +auxil/psb_z_hsort_x_mod.o: auxil/psb_z_hsort_mod.o -serial/psb_base_mat_mod.o: aux/psi_serial_mod.o +auxil/psi_serial_mod.o: auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o \ + auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o +auxil/psi_m_serial_mod.o auxil/psi_e_serial_mod.o auxil/psi_s_serial_mod.o auxil/psi_d_serial_mod.o auxil/psi_c_serial_mod.o auxil/psi_z_serial_mod.o: psb_const_mod.o + +auxil/psb_ip_reord_mod.o: auxil/psb_m_ip_reord_mod.o auxil/psb_e_ip_reord_mod.o \ + auxil/psb_s_ip_reord_mod.o auxil/psb_d_ip_reord_mod.o \ + auxil/psb_c_ip_reord_mod.o auxil/psb_z_ip_reord_mod.o + +#serial/psb_ld_base_mat_mod.o: serial/psb_lbase_mat_mod.o +#serial/psb_ld_csc_mat_mod.o serial/psb_ld_csr_mat_mod.o: serial/psb_ld_base_mat_mod.o + +serial/psb_base_mat_mod.o: auxil/psi_serial_mod.o serial/psb_s_base_mat_mod.o serial/psb_d_base_mat_mod.o serial/psb_c_base_mat_mod.o serial/psb_z_base_mat_mod.o: serial/psb_base_mat_mod.o +#serial/psb_ld_base_mat_mod.o: serial/psb_base_mat_mod.o serial/psb_s_base_mat_mod.o: serial/psb_s_base_vect_mod.o serial/psb_d_base_mat_mod.o: serial/psb_d_base_vect_mod.o +#serial/psb_ld_base_mat_mod.o: serial/psb_d_base_vect_mod.o serial/psb_c_base_mat_mod.o: serial/psb_c_base_vect_mod.o serial/psb_z_base_mat_mod.o: serial/psb_z_base_vect_mod.o -serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: serial/psb_i_base_vect_mod.o -serial/psb_i_base_vect_mod.o serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: aux/psi_serial_mod.o psb_realloc_mod.o -serial/psb_s_mat_mod.o: serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_vect_mod.o -serial/psb_d_mat_mod.o: serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_vect_mod.o serial/psb_i_vect_mod.o -serial/psb_c_mat_mod.o: serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_vect_mod.o -serial/psb_z_mat_mod.o: serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_vect_mod.o -serial/psb_s_csc_mat_mod.o serial/psb_s_csr_mat_mod.o: serial/psb_s_base_mat_mod.o -serial/psb_d_csc_mat_mod.o serial/psb_d_csr_mat_mod.o: serial/psb_d_base_mat_mod.o -serial/psb_c_csc_mat_mod.o serial/psb_c_csr_mat_mod.o: serial/psb_c_base_mat_mod.o -serial/psb_z_csc_mat_mod.o serial/psb_z_csr_mat_mod.o: serial/psb_z_base_mat_mod.o +serial/psb_l_base_vect_mod.o: serial/psb_i_base_vect_mod.o +serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o +serial/psb_i_base_vect_mod.o serial/psb_l_base_vect_mod.o serial/psb_c_base_vect_mod.o serial/psb_s_base_vect_mod.o serial/psb_d_base_vect_mod.o serial/psb_z_base_vect_mod.o: auxil/psi_serial_mod.o psb_realloc_mod.o +serial/psb_s_mat_mod.o: serial/psb_s_base_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_s_csc_mat_mod.o serial/psb_s_vect_mod.o \ + serial/psb_i_vect_mod.o +serial/psb_d_mat_mod.o: serial/psb_d_base_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_d_csc_mat_mod.o serial/psb_d_vect_mod.o \ + serial/psb_i_vect_mod.o +serial/psb_c_mat_mod.o: serial/psb_c_base_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_c_csc_mat_mod.o serial/psb_c_vect_mod.o \ + serial/psb_i_vect_mod.o +serial/psb_z_mat_mod.o: serial/psb_z_base_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_z_csc_mat_mod.o serial/psb_z_vect_mod.o \ + serial/psb_i_vect_mod.o +serial/psb_s_csc_mat_mod.o serial/psb_s_csr_mat_mod.o serial/psb_ls_csr_mat_mod.o: serial/psb_s_base_mat_mod.o +serial/psb_d_csc_mat_mod.o serial/psb_d_csr_mat_mod.o serial/psb_ld_csr_mat_mod.o: serial/psb_d_base_mat_mod.o +serial/psb_c_csc_mat_mod.o serial/psb_c_csr_mat_mod.o serial/psb_lc_csr_mat_mod.o: serial/psb_c_base_mat_mod.o +serial/psb_z_csc_mat_mod.o serial/psb_z_csr_mat_mod.o serial/psb_lz_csr_mat_mod.o: serial/psb_z_base_mat_mod.o + serial/psb_mat_mod.o: serial/psb_vect_mod.o serial/psb_s_mat_mod.o serial/psb_d_mat_mod.o serial/psb_c_mat_mod.o serial/psb_z_mat_mod.o serial/psb_serial_mod.o: serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o serial/psb_i_vect_mod.o: serial/psb_i_base_vect_mod.o +serial/psb_l_vect_mod.o: serial/psb_l_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_s_vect_mod.o: serial/psb_s_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_d_vect_mod.o: serial/psb_d_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_c_vect_mod.o: serial/psb_c_base_vect_mod.o serial/psb_i_vect_mod.o serial/psb_z_vect_mod.o: serial/psb_z_base_vect_mod.o serial/psb_i_vect_mod.o -serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o: serial/psb_mat_mod.o aux/psb_string_mod.o aux/psb_sort_mod.o aux/psi_serial_mod.o -serial/psb_vect_mod.o: serial/psb_i_vect_mod.o serial/psb_d_vect_mod.o serial/psb_s_vect_mod.o serial/psb_c_vect_mod.o serial/psb_z_vect_mod.o +serial/psb_s_serial_mod.o serial/psb_d_serial_mod.o serial/psb_c_serial_mod.o serial/psb_z_serial_mod.o: serial/psb_mat_mod.o auxil/psb_string_mod.o auxil/psb_sort_mod.o auxil/psi_serial_mod.o +serial/psb_vect_mod.o: serial/psb_i_vect_mod.o serial/psb_l_vect_mod.o serial/psb_d_vect_mod.o serial/psb_s_vect_mod.o serial/psb_c_vect_mod.o serial/psb_z_vect_mod.o error.o psb_realloc_mod.o: psb_error_mod.o psb_error_impl.o: psb_penv_mod.o -psb_spmat_type.o: aux/psb_string_mod.o aux/psb_sort_mod.o +psb_spmat_type.o: auxil/psb_string_mod.o auxil/psb_sort_mod.o desc/psb_desc_mod.o: psb_penv_mod.o psb_realloc_mod.o\ - aux/psb_hash_mod.o desc/psb_hash_map_mod.o desc/psb_list_map_mod.o \ + desc/psb_hash_mod.o desc/psb_hash_map_mod.o desc/psb_list_map_mod.o \ desc/psb_repl_map_mod.o desc/psb_gen_block_map_mod.o desc/psb_desc_const_mod.o\ desc/psb_indx_map_mod.o serial/psb_i_vect_mod.o -psi_i_mod.o: desc/psb_desc_mod.o serial/psb_i_vect_mod.o -psi_s_mod.o: desc/psb_desc_mod.o serial/psb_s_vect_mod.o -psi_d_mod.o: desc/psb_desc_mod.o serial/psb_d_vect_mod.o -psi_c_mod.o: desc/psb_desc_mod.o serial/psb_c_vect_mod.o -psi_z_mod.o: desc/psb_desc_mod.o serial/psb_z_vect_mod.o -psi_mod.o: psb_penv_mod.o desc/psb_desc_mod.o aux/psi_serial_mod.o serial/psb_serial_mod.o\ - psi_i_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o -desc/psb_indx_map_mod.o: desc/psb_desc_const_mod.o psb_error_mod.o psb_penv_mod.o +psi_i_mod.o: desc/psb_desc_mod.o serial/psb_i_vect_mod.o comm/psi_e_comm_a_mod.o \ + comm/psi_m_comm_a_mod.o comm/psi_i_comm_v_mod.o +psi_l_mod.o: desc/psb_desc_mod.o serial/psb_l_vect_mod.o comm/psi_e_comm_a_mod.o \ + comm/psi_m_comm_a_mod.o comm/psi_l_comm_v_mod.o +psi_s_mod.o: desc/psb_desc_mod.o serial/psb_s_vect_mod.o comm/psi_s_comm_a_mod.o \ + comm/psi_s_comm_v_mod.o +psi_d_mod.o: desc/psb_desc_mod.o serial/psb_d_vect_mod.o comm/psi_d_comm_a_mod.o \ + comm/psi_d_comm_v_mod.o +psi_c_mod.o: desc/psb_desc_mod.o serial/psb_c_vect_mod.o comm/psi_c_comm_a_mod.o \ + comm/psi_c_comm_v_mod.o +psi_z_mod.o: desc/psb_desc_mod.o serial/psb_z_vect_mod.o comm/psi_z_comm_a_mod.o \ + comm/psi_z_comm_v_mod.o +psi_mod.o: psb_penv_mod.o desc/psb_desc_mod.o auxil/psi_serial_mod.o serial/psb_serial_mod.o\ + psi_i_mod.o psi_l_mod.o psi_s_mod.o psi_d_mod.o psi_c_mod.o psi_z_mod.o + +desc/psb_indx_map_mod.o: desc/psb_desc_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o desc/psb_hash_map_mod.o desc/psb_list_map_mod.o desc/psb_repl_map_mod.o desc/psb_gen_block_map_mod.o:\ desc/psb_indx_map_mod.o desc/psb_desc_const_mod.o \ - aux/psb_sort_mod.o psb_penv_mod.o + auxil/psb_sort_mod.o psb_penv_mod.o desc/psb_glist_map_mod.o: desc/psb_list_map_mod.o -desc/psb_hash_map_mod.o: aux/psb_hash_mod.o aux/psb_sort_mod.o -desc/psb_gen_block_map_mod.o: aux/psb_hash_mod.o +desc/psb_hash_map_mod.o: desc/psb_hash_mod.o auxil/psb_sort_mod.o +desc/psb_gen_block_map_mod.o: desc/psb_hash_mod.o +desc/psb_hash_mod.o: psb_cbind_const_mod.o psb_check_mod.o: desc/psb_desc_mod.o @@ -129,17 +277,55 @@ comm/psb_c_linmap_mod.o: comm/psb_base_linmap_mod.o serial/psb_c_mat_mod.o seria comm/psb_z_linmap_mod.o: comm/psb_base_linmap_mod.o serial/psb_z_mat_mod.o serial/psb_z_vect_mod.o comm/psb_base_linmap_mod.o: desc/psb_desc_mod.o serial/psb_serial_mod.o comm/psb_comm_mod.o comm/psb_comm_mod.o: desc/psb_desc_mod.o serial/psb_mat_mod.o -comm/psb_comm_mod.o: comm/psb_i_comm_mod.o comm/psb_s_comm_mod.o comm/psb_d_comm_mod.o comm/psb_c_comm_mod.o comm/psb_z_comm_mod.o -comm/psb_i_comm_mod.o: serial/psb_i_vect_mod.o desc/psb_desc_mod.o +comm/psb_comm_mod.o: comm/psb_i_comm_mod.o comm/psb_l_comm_mod.o \ + comm/psb_s_comm_mod.o comm/psb_d_comm_mod.o \ + comm/psb_c_comm_mod.o comm/psb_z_comm_mod.o \ + comm/psb_m_comm_a_mod.o comm/psb_e_comm_a_mod.o \ + comm/psb_s_comm_a_mod.o comm/psb_d_comm_a_mod.o\ + comm/psb_c_comm_a_mod.o comm/psb_z_comm_a_mod.o + +comm/psb_m_comm_a_mod.o comm/psb_e_comm_a_mod.o \ +comm/psb_s_comm_a_mod.o comm/psb_d_comm_a_mod.o\ +comm/psb_c_comm_a_mod.o comm/psb_z_comm_a_mod.o: desc/psb_desc_mod.o + +comm/psb_i_comm_mod.o: serial/psb_i_vect_mod.o desc/psb_desc_mod.o +comm/psb_l_comm_mod.o: serial/psb_l_vect_mod.o desc/psb_desc_mod.o comm/psb_s_comm_mod.o: serial/psb_s_vect_mod.o desc/psb_desc_mod.o serial/psb_mat_mod.o comm/psb_d_comm_mod.o: serial/psb_d_vect_mod.o desc/psb_desc_mod.o serial/psb_mat_mod.o comm/psb_c_comm_mod.o: serial/psb_c_vect_mod.o desc/psb_desc_mod.o serial/psb_mat_mod.o comm/psb_z_comm_mod.o: serial/psb_z_vect_mod.o desc/psb_desc_mod.o serial/psb_mat_mod.o +comm/psi_i_comm_v_mod.o: serial/psb_i_vect_mod.o comm/psi_e_comm_a_mod.o \ + comm/psi_m_comm_a_mod.o +comm/psi_l_comm_v_mod.o: serial/psb_l_vect_mod.o comm/psi_e_comm_a_mod.o \ + comm/psi_m_comm_a_mod.o +comm/psi_s_comm_v_mod.o: serial/psb_s_vect_mod.o comm/psi_s_comm_a_mod.o +comm/psi_d_comm_v_mod.o: serial/psb_d_vect_mod.o comm/psi_d_comm_a_mod.o +comm/psi_c_comm_v_mod.o: serial/psb_c_vect_mod.o comm/psi_c_comm_a_mod.o +comm/psi_z_comm_v_mod.o: serial/psb_z_vect_mod.o comm/psi_z_comm_a_mod.o + +comm/psi_e_comm_a_mod.o comm/psi_m_comm_a_mod.o \ +comm/psi_s_comm_a_mod.o comm/psi_d_comm_a_mod.o \ +comm/psi_c_comm_a_mod.o comm/psi_z_comm_a_mod.o: desc/psb_desc_mod.o + + + tools/psb_tools_mod.o: tools/psb_cd_tools_mod.o tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o\ - tools/psb_i_tools_mod.o tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o -tools/psb_cd_tools_mod.o tools/psb_i_tools_mod.o tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o: desc/psb_desc_mod.o psi_mod.o serial/psb_mat_mod.o -tools/psb_i_tools_mod.o: serial/psb_i_vect_mod.o + tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ + tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o \ + tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ + tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ + tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o + + +tools/psb_cd_tools_mod.o tools/psb_i_tools_mod.o tools/psb_l_tools_mod.o \ +tools/psb_s_tools_mod.o tools/psb_d_tools_mod.o \ +tools/psb_c_tools_mod.o tools/psb_z_tools_mod.o tools/psb_m_tools_a_mod.o tools/psb_e_tools_a_mod.o \ +tools/psb_s_tools_a_mod.o tools/psb_d_tools_a_mod.o\ +tools/psb_c_tools_a_mod.o tools/psb_z_tools_a_mod.o: desc/psb_desc_mod.o psi_mod.o serial/psb_mat_mod.o + +tools/psb_i_tools_mod.o: serial/psb_i_vect_mod.o +tools/psb_l_tools_mod.o: serial/psb_l_vect_mod.o tools/psb_s_tools_mod.o: serial/psb_s_vect_mod.o tools/psb_d_tools_mod.o: serial/psb_d_vect_mod.o tools/psb_c_tools_mod.o: serial/psb_c_vect_mod.o @@ -155,22 +341,19 @@ psblas/psb_s_psblas_mod.o psblas/psb_c_psblas_mod.o psblas/psb_d_psblas_mod.o ps psb_base_mod.o: $(MODULES) -psi_penv_mod.o: psi_penv_mod.F90 $(BASIC_MODS) serial/psb_vect_mod.o serial/psb_mat_mod.o +penv/psi_penv_mod.o: penv/psi_penv_mod.F90 $(BASIC_MODS) serial/psb_vect_mod.o serial/psb_mat_mod.o $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ psb_penv_mod.o: psb_penv_mod.F90 $(COMMINT) $(BASIC_MODS) $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ -psi_comm_buffers_mod.o: psi_comm_buffers_mod.F90 $(BASIC_MODS) +penv/psi_comm_buffers_mod.o: penv/psi_comm_buffers_mod.F90 $(BASIC_MODS) $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ -psi_p2p_mod.o: psi_p2p_mod.F90 $(BASIC_MODS) +penv/psi_p2p_mod.o: penv/psi_p2p_mod.F90 $(BASIC_MODS) $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ -psi_bcast_mod.o: psi_bcast_mod.F90 $(BASIC_MODS) - $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ - -psi_reduce_mod.o: psi_reduce_mod.F90 $(BASIC_MODS) +penv/psi_collective_mod.o: penv/psi_collective_mod.F90 $(BASIC_MODS) $(FC) $(FINCLUDES) $(FDEFINES) $(FCOPT) $(EXTRA_OPT) -c $< -o $@ clean: diff --git a/base/modules/README.F2003 b/base/modules/README.F2003 index ade965aaa..90d474d2b 100644 --- a/base/modules/README.F2003 +++ b/base/modules/README.F2003 @@ -98,6 +98,82 @@ Design principles for this directory. AND IT'S DONE! Nothing else in the library requires the explicit knowledge of type of MOLD. - +3. Data precisoin (aka KIND / aka byte size) + Data precision is a bit of a thorny issue here, because it is used + by the Fortran language to disambiguate generic interfaces. This + means that we must be careful when choosing precision for data + structures. On the other hand, we want to have some freedom of + choice. The sticky point here is how to deal with integers, because + real and complex are already standardized on S/D/C/Z. + Integers are tricky because we do not want to use large integer + sizes (read: 8 bytes) unless they are really necessary; moreover, + the GPU code currently use 4 byte integers (and with good + reason). However if we want to tackle large index spaces, we will + need at some point 8-byte integers. + + So, here is the plan. + A. We have two basic integer kinds, 4-byte PSB_MPK_ which takes its + name from being the kind that is going to be passed to MPI for + all arguments other than data buffers, and 8-byte PSB_EPK_, to + be used as necessary; the PSB_SIZEOF functions which return + data structure sizes (sometimes summed over all processes) are + always 8-byte. + + B. At all levels where a function/subroutine is supposed to be + interfaced with an array of integers, there should be two + versions, distinguished by an M or an E in the specific name, + all adding to a generic set. This applies to the internal + utilities, such as sorting and reallocation. + + C. For computation we have I and L, as in psb_ipk_ and + psb_lpk_. The idea is that I<=L, and I is used for almost + everything, e.g. for the integer parts of the sparse matrix data + structures. L is only used for a very small subset of data, and + specifically for the indices in *GLOBAL* numbering mode, hence + the I<=L constraint. + + D. The values for I and L can be remapped independently at + configure time over M and E; thus, if a sparse matrix routine is + reallocating integer data through the generic names of the + utilities, the PSB_IPK_ is remapped at compile time onto + PSB_MPK_ or PSB_EPK_ as needed. + + E. Because we must have I<=L, this means that supported + configurations are (I=4,L=4), (I=4,L=8), (I=8,L=8). Default + is (I=4,L=8), because it allows us to go to multi-billion linear + systems while still keeping all local data structures on 4-byte + integers. + + F. Thus, care must be taken in defining specific interfaces: to + reiterate, if we are dealing with an interface which accepts an + integer array, it should be defined with M and E (which are + always distinct) and not I/L (which might be + indistinguishable). Example in case: + interface psb_realloc + Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb) + integer(psb_mpk_),Intent(in) :: len + integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + G. The INFO argument and others related to error handling should + always be PSB_IPK_; + + H. Arguments related to MPI interfacing should always be PSB_MPK_ + + I. Encapsulated types such as psb_i_base_vect_mod can still be I + and L, because if the name of the type is different, the types + are interpreted as distinguishable even when the contents are + identical. + + L. This means that most user-level interfaces will deal in I and L, + not M and E, which are going to be used mostly in the + internals. + + M. Actually, the user will probably never see M, but will (for + sizeof & friends) see E. + + diff --git a/base/modules/aux/psb_ip_reord_mod.f90 b/base/modules/aux/psb_ip_reord_mod.f90 deleted file mode 100644 index 325bc1beb..000000000 --- a/base/modules/aux/psb_ip_reord_mod.f90 +++ /dev/null @@ -1,670 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! Reorder (an) input vector(s) based on a list sort output. -! Based on: D. E. Knuth: The Art of Computer Programming -! vol. 3: Sorting and Searching, Addison Wesley, 1973 -! ex. 5.2.12 -! -! -module psb_ip_reord_mod - use psb_const_mod - - interface psb_ip_reord - module procedure psb_ip_reord_i1,& - & psb_ip_reord_s1, psb_ip_reord_d1,& - & psb_ip_reord_c1, psb_ip_reord_z1,& - & psb_ip_reord_i1i1,& - & psb_ip_reord_s1i1, psb_ip_reord_d1i1,& - & psb_ip_reord_c1i1, psb_ip_reord_z1i1,& - & psb_ip_reord_s1i2, psb_ip_reord_d1i2,& - & psb_ip_reord_c1i2, psb_ip_reord_z1i2,& - & psb_ip_reord_s1i3, psb_ip_reord_d1i3,& - & psb_ip_reord_c1i3, psb_ip_reord_z1i3 - - - end interface - -contains - - subroutine psb_ip_reord_i1(n,x,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - integer(psb_ipk_) :: x(*) - - integer(psb_ipk_) :: lswap, lp, k - integer(psb_ipk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_i1 - - - subroutine psb_ip_reord_s1(n,x,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - real(psb_spk_) :: x(*) - - integer(psb_ipk_) :: lswap, lp, k - real(psb_spk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_s1 - - subroutine psb_ip_reord_d1(n,x,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - real(psb_dpk_) :: x(*) - - integer(psb_ipk_) :: lswap, lp, k - real(psb_dpk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_d1 - - - - subroutine psb_ip_reord_c1(n,x,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - complex(psb_spk_) :: x(*) - - integer(psb_ipk_) :: lswap, lp, k - complex(psb_spk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_c1 - - subroutine psb_ip_reord_z1(n,x,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - complex(psb_dpk_) :: x(*) - - integer(psb_ipk_) :: lswap, lp, k - complex(psb_dpk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_z1 - - - subroutine psb_ip_reord_i1i1(n,x,indx,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - integer(psb_ipk_) :: x(*) - integer(psb_ipk_) :: indx(*) - - integer(psb_ipk_) :: lswap, lp, k, ixswap - integer(psb_ipk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - ixswap = indx(lp) - indx(lp) = indx(k) - indx(k) = ixswap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_i1i1 - - - subroutine psb_ip_reord_s1i1(n,x,indx,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - real(psb_spk_) :: x(*) - integer(psb_ipk_) :: indx(*) - - - integer(psb_ipk_) :: lswap, lp, k, ixswap - real(psb_spk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - ixswap = indx(lp) - indx(lp) = indx(k) - indx(k) = ixswap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_s1i1 - - subroutine psb_ip_reord_d1i1(n,x,indx,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - real(psb_dpk_) :: x(*) - integer(psb_ipk_) :: indx(*) - - integer(psb_ipk_) :: lswap, lp, k, ixswap - real(psb_dpk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - ixswap = indx(lp) - indx(lp) = indx(k) - indx(k) = ixswap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_d1i1 - - - - subroutine psb_ip_reord_c1i1(n,x,indx,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - complex(psb_spk_) :: x(*) - integer(psb_ipk_) :: indx(*) - - integer(psb_ipk_) :: lswap, lp, k, ixswap - complex(psb_spk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - ixswap = indx(lp) - indx(lp) = indx(k) - indx(k) = ixswap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_c1i1 - - subroutine psb_ip_reord_z1i1(n,x,indx,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - complex(psb_dpk_) :: x(*) - integer(psb_ipk_) :: indx(*) - - integer(psb_ipk_) :: lswap, lp, k, ixswap - complex(psb_dpk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - ixswap = indx(lp) - indx(lp) = indx(k) - indx(k) = ixswap - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_z1i1 - - - subroutine psb_ip_reord_s1i2(n,x,i1,i2,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - real(psb_spk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) - - - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 - real(psb_spk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - isw1 = i1(lp) - i1(lp) = i1(k) - i1(k) = isw1 - isw2 = i2(lp) - i2(lp) = i2(k) - i2(k) = isw2 - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_s1i2 - - subroutine psb_ip_reord_d1i2(n,x,i1,i2,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - real(psb_dpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) - - - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 - real(psb_dpk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - isw1 = i1(lp) - i1(lp) = i1(k) - i1(k) = isw1 - isw2 = i2(lp) - i2(lp) = i2(k) - i2(k) = isw2 - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_d1i2 - - subroutine psb_ip_reord_c1i2(n,x,i1,i2,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - complex(psb_spk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) - - - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 - complex(psb_spk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - isw1 = i1(lp) - i1(lp) = i1(k) - i1(k) = isw1 - isw2 = i2(lp) - i2(lp) = i2(k) - i2(k) = isw2 - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_c1i2 - - subroutine psb_ip_reord_z1i2(n,x,i1,i2,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - complex(psb_dpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*) - - - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2 - complex(psb_dpk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - isw1 = i1(lp) - i1(lp) = i1(k) - i1(k) = isw1 - isw2 = i2(lp) - i2(lp) = i2(k) - i2(k) = isw2 - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_z1i2 - - - subroutine psb_ip_reord_s1i3(n,x,i1,i2,i3,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - real(psb_spk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*), i3(*) - - - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2, isw3 - real(psb_spk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - isw1 = i1(lp) - i1(lp) = i1(k) - i1(k) = isw1 - isw2 = i2(lp) - i2(lp) = i2(k) - i2(k) = isw2 - isw3 = i3(lp) - i3(lp) = i3(k) - i3(k) = isw3 - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_s1i3 - - subroutine psb_ip_reord_d1i3(n,x,i1,i2,i3,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - real(psb_dpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*),i3(*) - - - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2,isw3 - real(psb_dpk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - isw1 = i1(lp) - i1(lp) = i1(k) - i1(k) = isw1 - isw2 = i2(lp) - i2(lp) = i2(k) - i2(k) = isw2 - isw3 = i3(lp) - i3(lp) = i3(k) - i3(k) = isw3 - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_d1i3 - - subroutine psb_ip_reord_c1i3(n,x,i1,i2,i3,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - complex(psb_spk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*), i3(*) - - - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2, isw3 - complex(psb_spk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - isw1 = i1(lp) - i1(lp) = i1(k) - i1(k) = isw1 - isw2 = i2(lp) - i2(lp) = i2(k) - i2(k) = isw2 - isw3 = i3(lp) - i3(lp) = i3(k) - i3(k) = isw3 - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_c1i3 - - subroutine psb_ip_reord_z1i3(n,x,i1,i2,i3,iaux) - integer(psb_ipk_), intent(in) :: n - integer(psb_ipk_) :: iaux(0:*) - complex(psb_dpk_) :: x(*) - integer(psb_ipk_) :: i1(*), i2(*), i3(*) - - - integer(psb_ipk_) :: lswap, lp, k, isw1, isw2, isw3 - complex(psb_dpk_) :: swap - - lp = iaux(0) - k = 1 - do - if ((lp == 0).or.(k>n)) exit - do - if (lp >= k) exit - lp = iaux(lp) - end do - swap = x(lp) - x(lp) = x(k) - x(k) = swap - isw1 = i1(lp) - i1(lp) = i1(k) - i1(k) = isw1 - isw2 = i2(lp) - i2(lp) = i2(k) - i2(k) = isw2 - isw3 = i3(lp) - i3(lp) = i3(k) - i3(k) = isw3 - lswap = iaux(lp) - iaux(lp) = iaux(k) - iaux(k) = lp - lp = lswap - k = k + 1 - enddo - return - end subroutine psb_ip_reord_z1i3 - - -end module psb_ip_reord_mod diff --git a/base/modules/auxil/psb_c_hsort_mod.f90 b/base/modules/auxil/psb_c_hsort_mod.f90 new file mode 100644 index 000000000..43b22ec4b --- /dev/null +++ b/base/modules/auxil/psb_c_hsort_mod.f90 @@ -0,0 +1,125 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_c_hsort_mod + use psb_const_mod + + interface psb_hsort + subroutine psb_chsort(x,ix,dir,flag) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_chsort + end interface psb_hsort + + + interface psi_insert_heap + subroutine psi_c_insert_heap(key,last,heap,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + complex(psb_spk_), intent(in) :: key + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_c_insert_heap + end interface psi_insert_heap + + interface psi_idx_insert_heap + subroutine psi_c_idx_insert_heap(key,index,last,heap,idxs,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + complex(psb_spk_), intent(in) :: key + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_c_idx_insert_heap + end interface psi_idx_insert_heap + + + interface psi_heap_get_first + subroutine psi_c_heap_get_first(key,last,heap,dir,info) + import + implicit none + complex(psb_spk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_c_heap_get_first + end interface psi_heap_get_first + + interface psi_idx_heap_get_first + subroutine psi_c_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import + complex(psb_spk_), intent(inout) :: key + integer(psb_ipk_), intent(out) :: index + complex(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_c_idx_heap_get_first + end interface psi_idx_heap_get_first + + +end module psb_c_hsort_mod diff --git a/base/modules/auxil/psb_c_hsort_x_mod.f90 b/base/modules/auxil/psb_c_hsort_x_mod.f90 new file mode 100644 index 000000000..4331c567a --- /dev/null +++ b/base/modules/auxil/psb_c_hsort_x_mod.f90 @@ -0,0 +1,308 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_c_hsort_x_mod + use psb_const_mod + use psb_c_hsort_mod + + type psb_c_heap + integer(psb_ipk_) :: last, dir + complex(psb_spk_), allocatable :: keys(:) + contains + procedure, pass(heap) :: init => psb_c_init_heap + procedure, pass(heap) :: howmany => psb_c_howmany + procedure, pass(heap) :: insert => psb_c_insert_heap + procedure, pass(heap) :: get_first => psb_c_heap_get_first + procedure, pass(heap) :: dump => psb_c_dump_heap + procedure, pass(heap) :: free => psb_c_free_heap + end type psb_c_heap + + type psb_c_idx_heap + integer(psb_ipk_) :: last, dir + complex(psb_spk_), allocatable :: keys(:) + integer(psb_ipk_), allocatable :: idxs(:) + contains + procedure, pass(heap) :: init => psb_c_idx_init_heap + procedure, pass(heap) :: howmany => psb_c_idx_howmany + procedure, pass(heap) :: insert => psb_c_idx_insert_heap + procedure, pass(heap) :: get_first => psb_c_idx_heap_get_first + procedure, pass(heap) :: dump => psb_c_idx_dump_heap + procedure, pass(heap) :: free => psb_c_idx_free_heap + end type psb_c_idx_heap + + +contains + + subroutine psb_c_init_heap(heap,info,dir) + use psb_realloc_mod, only : psb_ensure_size + implicit none + class(psb_c_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dir + + info = psb_success_ + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_asort_up_ + endif + select case(heap%dir) + case (psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(psb_err_unit,*) 'Invalid direction, defaulting to psb_asort_up_' + heap%dir = psb_asort_up_ + end select + call psb_ensure_size(psb_heap_resize,heap%keys,info) + + return + end subroutine psb_c_init_heap + + + function psb_c_howmany(heap) result(res) + implicit none + class(psb_c_heap), intent(in) :: heap + integer(psb_ipk_) :: res + res = heap%last + end function psb_c_howmany + + subroutine psb_c_insert_heap(key,heap,info) + use psb_realloc_mod, only : psb_ensure_size + implicit none + + complex(psb_spk_), intent(in) :: key + class(psb_c_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + if (heap%last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_heap(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_c_insert_heap + + subroutine psb_c_heap_get_first(key,heap,info) + implicit none + + class(psb_c_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), intent(out) :: key + + + info = psb_success_ + + call psi_heap_get_first(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_c_heap_get_first + + subroutine psb_c_dump_heap(iout,heap,info) + + implicit none + class(psb_c_heap), intent(in) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iout + + info = psb_success_ + if (iout < 0) then + write(psb_err_unit,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs)n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1m + + subroutine psb_ip_reord_c1m1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1m1 + + subroutine psb_ip_reord_c1m2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*) + + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1m2 + + subroutine psb_ip_reord_c1m3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1m3 + + + subroutine psb_ip_reord_c1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1e + + subroutine psb_ip_reord_c1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1e1 + + subroutine psb_ip_reord_c1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1e2 + + subroutine psb_ip_reord_c1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_spk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + complex(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_c1e3 + +end module psb_c_ip_reord_mod diff --git a/base/modules/auxil/psb_c_isort_mod.f90 b/base/modules/auxil/psb_c_isort_mod.f90 new file mode 100644 index 000000000..d0dbd2815 --- /dev/null +++ b/base/modules/auxil/psb_c_isort_mod.f90 @@ -0,0 +1,127 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_c_isort_mod + use psb_const_mod + + interface psb_isort + subroutine psb_cisort(x,ix,dir,flag) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_cisort + end interface psb_isort + + + + interface + subroutine psi_clisrx_up(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_clisrx_up + subroutine psi_clisrx_dw(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_clisrx_dw + subroutine psi_clisr_up(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_clisr_up + subroutine psi_clisr_dw(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_clisr_dw + subroutine psi_calisrx_up(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_calisrx_up + subroutine psi_calisrx_dw(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_calisrx_dw + subroutine psi_calisr_up(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_calisr_up + subroutine psi_calisr_dw(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_calisr_dw + subroutine psi_caisrx_up(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_caisrx_up + subroutine psi_caisrx_dw(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_caisrx_dw + subroutine psi_caisr_up(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_caisr_up + subroutine psi_caisr_dw(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_caisr_dw + end interface + + +end module psb_c_isort_mod diff --git a/base/modules/auxil/psb_c_msort_mod.f90 b/base/modules/auxil/psb_c_msort_mod.f90 new file mode 100644 index 000000000..a74c32fd7 --- /dev/null +++ b/base/modules/auxil/psb_c_msort_mod.f90 @@ -0,0 +1,121 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_c_msort_mod + use psb_const_mod + + + interface psb_msort_unique + subroutine psb_cmsort_u(x,nout,dir) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + end subroutine psb_cmsort_u + end interface psb_msort_unique + + + interface psb_msort + subroutine psb_cmsort(x,ix,dir,flag) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_cmsort + end interface psb_msort + + interface psi_lmsort_up + subroutine psi_c_lmsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_lmsort_up + end interface psi_lmsort_up + interface psi_lmsort_dw + subroutine psi_c_lmsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_lmsort_dw + end interface psi_lmsort_dw + interface psi_almsort_up + subroutine psi_c_almsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_almsort_up + end interface psi_almsort_up + interface psi_almsort_dw + subroutine psi_c_almsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_almsort_dw + end interface psi_almsort_dw + interface psi_amsort_up + subroutine psi_c_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_amsort_up + end interface psi_amsort_up + interface psi_amsort_dw + subroutine psi_c_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_c_amsort_dw + end interface psi_amsort_dw + +end module psb_c_msort_mod diff --git a/base/modules/auxil/psb_c_qsort_mod.f90 b/base/modules/auxil/psb_c_qsort_mod.f90 new file mode 100644 index 000000000..8b365222c --- /dev/null +++ b/base/modules/auxil/psb_c_qsort_mod.f90 @@ -0,0 +1,126 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_c_qsort_mod + use psb_const_mod + + + + interface psb_qsort + subroutine psb_cqsort(x,ix,dir,flag) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_cqsort + end interface psb_qsort + + interface + subroutine psi_clqsrx_up(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_clqsrx_up + subroutine psi_clqsrx_dw(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_clqsrx_dw + subroutine psi_clqsr_up(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_clqsr_up + subroutine psi_clqsr_dw(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_clqsr_dw + subroutine psi_calqsrx_up(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_calqsrx_up + subroutine psi_calqsrx_dw(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_calqsrx_dw + subroutine psi_calqsr_up(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_calqsr_up + subroutine psi_calqsr_dw(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_calqsr_dw + subroutine psi_caqsrx_up(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_caqsrx_up + subroutine psi_caqsrx_dw(n,x,ix) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_caqsrx_dw + subroutine psi_caqsr_up(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_caqsr_up + subroutine psi_caqsr_dw(n,x) + import + complex(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_caqsr_dw + end interface + +end module psb_c_qsort_mod diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 new file mode 100644 index 000000000..b9f3642b4 --- /dev/null +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_c_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_c_rk1 + module procedure psb_r_m_c_rk2 + module procedure psb_r_e_c_rk1 + module procedure psb_r_e_c_rk2 + module procedure psb_r_me_c_rk2 + module procedure psb_r_em_c_rk2 + + module procedure psb_r_m_2_c_rk1 + module procedure psb_r_e_2_c_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_c_rk1, psb_move_alloc_c_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_c_rk1, psb_ab_cpy_c_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_c_rk1, psb_cpy_c_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_c_rk1, psb_ensure_e_sz_c_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_c_rk1, psb_size_c_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_c_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + complex(psb_spk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_spk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_c_rk1 + + Subroutine psb_r_m_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_c_rk2 + + + Subroutine psb_r_e_c_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + complex(psb_spk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_spk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_c_rk1 + + Subroutine psb_r_e_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_c_rk2 + + Subroutine psb_r_me_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_c_rk2 + + Subroutine psb_r_em_c_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + complex(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_c_rk2 + + Subroutine psb_r_m_2_c_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_c_rk1 + + Subroutine psb_r_e_2_c_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + complex(psb_spk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_c_rk1 + + + + subroutine psb_ab_cpy_c_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), allocatable, intent(in) :: vin(:) + complex(psb_spk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_c_rk1 + + subroutine psb_ab_cpy_c_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), allocatable, intent(in) :: vin(:,:) + complex(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_c_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_c_rk2 + + + subroutine psb_cpy_c_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), intent(in) :: vin(:) + complex(psb_spk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_c_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_c_rk1 + + subroutine psb_cpy_c_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_spk_), intent(in) :: vin(:,:) + complex(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_c_rk2 + + + function psb_size_c_rk1(vin) result(val) + integer(psb_epk_) :: val + complex(psb_spk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_c_rk1 + + + function psb_size_c_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + complex(psb_spk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_c_rk2 + + Subroutine psb_ensure_m_sz_c_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + complex(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_c_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_c_rk1 + + Subroutine psb_ensure_e_sz_c_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + complex(psb_spk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + complex(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_c_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_c_rk1 + + Subroutine psb_move_alloc_c_rk1(vin,vout,info) + use psb_error_mod + complex(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_c_rk1 + + Subroutine psb_move_alloc_c_rk2(vin,vout,info) + use psb_error_mod + complex(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_c_rk2 + +end module psb_c_realloc_mod diff --git a/base/modules/aux/psb_c_sort_mod.f90 b/base/modules/auxil/psb_c_sort_mod.f90 similarity index 99% rename from base/modules/aux/psb_c_sort_mod.f90 rename to base/modules/auxil/psb_c_sort_mod.f90 index e99adab2d..137c9eb53 100644 --- a/base/modules/aux/psb_c_sort_mod.f90 +++ b/base/modules/auxil/psb_c_sort_mod.f90 @@ -44,6 +44,8 @@ module psb_c_sort_mod use psb_const_mod + @INTE@ + interface psb_msort_unique subroutine psb_cmsort_u(x,nout,dir) import @@ -553,7 +555,8 @@ contains implicit none class(psb_c_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info complex(psb_spk_), intent(out) :: key diff --git a/base/modules/auxil/psb_d_hsort_mod.f90 b/base/modules/auxil/psb_d_hsort_mod.f90 new file mode 100644 index 000000000..c1a7523c2 --- /dev/null +++ b/base/modules/auxil/psb_d_hsort_mod.f90 @@ -0,0 +1,125 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_d_hsort_mod + use psb_const_mod + + interface psb_hsort + subroutine psb_dhsort(x,ix,dir,flag) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_dhsort + end interface psb_hsort + + + interface psi_insert_heap + subroutine psi_d_insert_heap(key,last,heap,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + real(psb_dpk_), intent(in) :: key + real(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_d_insert_heap + end interface psi_insert_heap + + interface psi_idx_insert_heap + subroutine psi_d_idx_insert_heap(key,index,last,heap,idxs,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + real(psb_dpk_), intent(in) :: key + real(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_d_idx_insert_heap + end interface psi_idx_insert_heap + + + interface psi_heap_get_first + subroutine psi_d_heap_get_first(key,last,heap,dir,info) + import + implicit none + real(psb_dpk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + real(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_d_heap_get_first + end interface psi_heap_get_first + + interface psi_idx_heap_get_first + subroutine psi_d_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import + real(psb_dpk_), intent(inout) :: key + integer(psb_ipk_), intent(out) :: index + real(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_d_idx_heap_get_first + end interface psi_idx_heap_get_first + + +end module psb_d_hsort_mod diff --git a/base/modules/auxil/psb_d_hsort_x_mod.f90 b/base/modules/auxil/psb_d_hsort_x_mod.f90 new file mode 100644 index 000000000..df290e386 --- /dev/null +++ b/base/modules/auxil/psb_d_hsort_x_mod.f90 @@ -0,0 +1,308 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_d_hsort_x_mod + use psb_const_mod + use psb_d_hsort_mod + + type psb_d_heap + integer(psb_ipk_) :: last, dir + real(psb_dpk_), allocatable :: keys(:) + contains + procedure, pass(heap) :: init => psb_d_init_heap + procedure, pass(heap) :: howmany => psb_d_howmany + procedure, pass(heap) :: insert => psb_d_insert_heap + procedure, pass(heap) :: get_first => psb_d_heap_get_first + procedure, pass(heap) :: dump => psb_d_dump_heap + procedure, pass(heap) :: free => psb_d_free_heap + end type psb_d_heap + + type psb_d_idx_heap + integer(psb_ipk_) :: last, dir + real(psb_dpk_), allocatable :: keys(:) + integer(psb_ipk_), allocatable :: idxs(:) + contains + procedure, pass(heap) :: init => psb_d_idx_init_heap + procedure, pass(heap) :: howmany => psb_d_idx_howmany + procedure, pass(heap) :: insert => psb_d_idx_insert_heap + procedure, pass(heap) :: get_first => psb_d_idx_heap_get_first + procedure, pass(heap) :: dump => psb_d_idx_dump_heap + procedure, pass(heap) :: free => psb_d_idx_free_heap + end type psb_d_idx_heap + + +contains + + subroutine psb_d_init_heap(heap,info,dir) + use psb_realloc_mod, only : psb_ensure_size + implicit none + class(psb_d_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dir + + info = psb_success_ + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + call psb_ensure_size(psb_heap_resize,heap%keys,info) + + return + end subroutine psb_d_init_heap + + + function psb_d_howmany(heap) result(res) + implicit none + class(psb_d_heap), intent(in) :: heap + integer(psb_ipk_) :: res + res = heap%last + end function psb_d_howmany + + subroutine psb_d_insert_heap(key,heap,info) + use psb_realloc_mod, only : psb_ensure_size + implicit none + + real(psb_dpk_), intent(in) :: key + class(psb_d_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + if (heap%last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_heap(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_d_insert_heap + + subroutine psb_d_heap_get_first(key,heap,info) + implicit none + + class(psb_d_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(out) :: key + + + info = psb_success_ + + call psi_heap_get_first(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_d_heap_get_first + + subroutine psb_d_dump_heap(iout,heap,info) + + implicit none + class(psb_d_heap), intent(in) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iout + + info = psb_success_ + if (iout < 0) then + write(psb_err_unit,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs)n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1m + + subroutine psb_ip_reord_d1m1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1m1 + + subroutine psb_ip_reord_d1m2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*) + + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1m2 + + subroutine psb_ip_reord_d1m3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1m3 + + + subroutine psb_ip_reord_d1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1e + + subroutine psb_ip_reord_d1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1e1 + + subroutine psb_ip_reord_d1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1e2 + + subroutine psb_ip_reord_d1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_dpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + real(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_d1e3 + +end module psb_d_ip_reord_mod diff --git a/base/modules/auxil/psb_d_isort_mod.f90 b/base/modules/auxil/psb_d_isort_mod.f90 new file mode 100644 index 000000000..b34a3dfff --- /dev/null +++ b/base/modules/auxil/psb_d_isort_mod.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_d_isort_mod + use psb_const_mod + + interface psb_isort + subroutine psb_disort(x,ix,dir,flag) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_disort + end interface psb_isort + + + + interface + subroutine psi_disrx_up(n,x,ix) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_disrx_up + subroutine psi_disrx_dw(n,x,ix) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_disrx_dw + subroutine psi_disr_up(n,x) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_disr_up + subroutine psi_disr_dw(n,x) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_disr_dw + subroutine psi_daisrx_up(n,x,ix) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_daisrx_up + subroutine psi_daisrx_dw(n,x,ix) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_daisrx_dw + subroutine psi_daisr_up(n,x) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_daisr_up + subroutine psi_daisr_dw(n,x) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_daisr_dw + end interface + + +end module psb_d_isort_mod diff --git a/base/modules/auxil/psb_d_msort_mod.f90 b/base/modules/auxil/psb_d_msort_mod.f90 new file mode 100644 index 000000000..d035486b7 --- /dev/null +++ b/base/modules/auxil/psb_d_msort_mod.f90 @@ -0,0 +1,104 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_d_msort_mod + use psb_const_mod + + + interface psb_msort_unique + subroutine psb_dmsort_u(x,nout,dir) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + end subroutine psb_dmsort_u + end interface psb_msort_unique + + + interface psb_msort + subroutine psb_dmsort(x,ix,dir,flag) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_dmsort + end interface psb_msort + + + interface psi_msort_up + subroutine psi_d_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_d_msort_up + end interface psi_msort_up + interface psi_msort_dw + subroutine psi_d_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_d_msort_dw + end interface psi_msort_dw + interface psi_amsort_up + subroutine psi_d_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_d_amsort_up + end interface psi_amsort_up + interface psi_amsort_dw + subroutine psi_d_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_d_amsort_dw + end interface psi_amsort_dw + +end module psb_d_msort_mod diff --git a/base/modules/auxil/psb_d_qsort_mod.f90 b/base/modules/auxil/psb_d_qsort_mod.f90 new file mode 100644 index 000000000..4e1be1d1f --- /dev/null +++ b/base/modules/auxil/psb_d_qsort_mod.f90 @@ -0,0 +1,123 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_d_qsort_mod + use psb_const_mod + + + + interface psb_bsrch + function psb_dbsrch(key,n,v) result(ipos) + import + integer(psb_ipk_) :: ipos, n + real(psb_dpk_) :: key + real(psb_dpk_) :: v(:) + end function psb_dbsrch + end interface psb_bsrch + + interface psb_ssrch + function psb_dssrch(key,n,v) result(ipos) + import + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_dpk_) :: key + real(psb_dpk_) :: v(:) + end function psb_dssrch + end interface psb_ssrch + + interface psb_qsort + subroutine psb_dqsort(x,ix,dir,flag) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_dqsort + end interface psb_qsort + + interface + subroutine psi_dqsrx_up(n,x,ix) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_dqsrx_up + subroutine psi_dqsrx_dw(n,x,ix) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_dqsrx_dw + subroutine psi_dqsr_up(n,x) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_dqsr_up + subroutine psi_dqsr_dw(n,x) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_dqsr_dw + subroutine psi_daqsrx_up(n,x,ix) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_daqsrx_up + subroutine psi_daqsrx_dw(n,x,ix) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_daqsrx_dw + subroutine psi_daqsr_up(n,x) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_daqsr_up + subroutine psi_daqsr_dw(n,x) + import + real(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_daqsr_dw + end interface + +end module psb_d_qsort_mod diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 new file mode 100644 index 000000000..43ac91254 --- /dev/null +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_d_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_d_rk1 + module procedure psb_r_m_d_rk2 + module procedure psb_r_e_d_rk1 + module procedure psb_r_e_d_rk2 + module procedure psb_r_me_d_rk2 + module procedure psb_r_em_d_rk2 + + module procedure psb_r_m_2_d_rk1 + module procedure psb_r_e_2_d_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_d_rk1, psb_move_alloc_d_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_d_rk1, psb_ab_cpy_d_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_d_rk1, psb_cpy_d_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_d_rk1, psb_ensure_e_sz_d_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_d_rk1, psb_size_d_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_d_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + real(psb_dpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + real(psb_dpk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_d_rk1 + + Subroutine psb_r_m_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_d_rk2 + + + Subroutine psb_r_e_d_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + real(psb_dpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + real(psb_dpk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_d_rk1 + + Subroutine psb_r_e_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_d_rk2 + + Subroutine psb_r_me_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_d_rk2 + + Subroutine psb_r_em_d_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + real(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_d_rk2 + + Subroutine psb_r_m_2_d_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_d_rk1 + + Subroutine psb_r_e_2_d_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + real(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + real(psb_dpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_d_rk1 + + + + subroutine psb_ab_cpy_d_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), allocatable, intent(in) :: vin(:) + real(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_d_rk1 + + subroutine psb_ab_cpy_d_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), allocatable, intent(in) :: vin(:,:) + real(psb_dpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_d_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_d_rk2 + + + subroutine psb_cpy_d_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), intent(in) :: vin(:) + real(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_d_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_d_rk1 + + subroutine psb_cpy_d_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_dpk_), intent(in) :: vin(:,:) + real(psb_dpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_d_rk2 + + + function psb_size_d_rk1(vin) result(val) + integer(psb_epk_) :: val + real(psb_dpk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_d_rk1 + + + function psb_size_d_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + real(psb_dpk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_d_rk2 + + Subroutine psb_ensure_m_sz_d_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + real(psb_dpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + real(psb_dpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_d_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_d_rk1 + + Subroutine psb_ensure_e_sz_d_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + real(psb_dpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + real(psb_dpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_d_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_d_rk1 + + Subroutine psb_move_alloc_d_rk1(vin,vout,info) + use psb_error_mod + real(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_d_rk1 + + Subroutine psb_move_alloc_d_rk2(vin,vout,info) + use psb_error_mod + real(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_d_rk2 + +end module psb_d_realloc_mod diff --git a/base/modules/aux/psb_d_sort_mod.f90 b/base/modules/auxil/psb_d_sort_mod.f90 similarity index 99% rename from base/modules/aux/psb_d_sort_mod.f90 rename to base/modules/auxil/psb_d_sort_mod.f90 index 4505bcd7d..edf592879 100644 --- a/base/modules/aux/psb_d_sort_mod.f90 +++ b/base/modules/auxil/psb_d_sort_mod.f90 @@ -44,6 +44,8 @@ module psb_d_sort_mod use psb_const_mod + @INTE@ + interface psb_msort_unique subroutine psb_dmsort_u(x,nout,dir) import @@ -515,7 +517,8 @@ contains implicit none class(psb_d_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info real(psb_dpk_), intent(out) :: key diff --git a/base/modules/auxil/psb_e_hsort_mod.f90 b/base/modules/auxil/psb_e_hsort_mod.f90 new file mode 100644 index 000000000..3ce7ac45b --- /dev/null +++ b/base/modules/auxil/psb_e_hsort_mod.f90 @@ -0,0 +1,125 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_e_hsort_mod + use psb_const_mod + + interface psb_hsort + subroutine psb_ehsort(x,ix,dir,flag) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + end subroutine psb_ehsort + end interface psb_hsort + + + interface psi_insert_heap + subroutine psi_e_insert_heap(key,last,heap,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_epk_), intent(in) :: key + integer(psb_epk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_e_insert_heap + end interface psi_insert_heap + + interface psi_idx_insert_heap + subroutine psi_e_idx_insert_heap(key,index,last,heap,idxs,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_epk_), intent(in) :: key + integer(psb_epk_), intent(inout) :: heap(:) + integer(psb_epk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_e_idx_insert_heap + end interface psi_idx_insert_heap + + + interface psi_heap_get_first + subroutine psi_e_heap_get_first(key,last,heap,dir,info) + import + implicit none + integer(psb_epk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_e_heap_get_first + end interface psi_heap_get_first + + interface psi_idx_heap_get_first + subroutine psi_e_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import + integer(psb_epk_), intent(inout) :: key + integer(psb_epk_), intent(out) :: index + integer(psb_epk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_epk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_e_idx_heap_get_first + end interface psi_idx_heap_get_first + + +end module psb_e_hsort_mod diff --git a/base/modules/auxil/psb_e_ip_reord_mod.F90 b/base/modules/auxil/psb_e_ip_reord_mod.F90 new file mode 100644 index 000000000..7369d1f2f --- /dev/null +++ b/base/modules/auxil/psb_e_ip_reord_mod.F90 @@ -0,0 +1,320 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Reorder (an) input vector(s) based on a list sort output. +! Based on: D. E. Knuth: The Art of Computer Programming +! vol. 3: Sorting and Searching, Addison Wesley, 1973 +! ex. 5.2.12 +! +! +module psb_e_ip_reord_mod + use psb_const_mod + + interface psb_ip_reord + module procedure psb_ip_reord_e1m,& + & psb_ip_reord_e1m1, psb_ip_reord_e1m2,& + & psb_ip_reord_e1m3 + module procedure psb_ip_reord_e1e,& + & psb_ip_reord_e1e1, psb_ip_reord_e1e2,& + & psb_ip_reord_e1e3 + + + end interface + +contains + + subroutine psb_ip_reord_e1m(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_mpk_) :: lswap, lp, k + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1m + + subroutine psb_ip_reord_e1m1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1m1 + + subroutine psb_ip_reord_e1m2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*) + + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1m2 + + subroutine psb_ip_reord_e1m3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1m3 + + + subroutine psb_ip_reord_e1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1e + + subroutine psb_ip_reord_e1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1e1 + + subroutine psb_ip_reord_e1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1e2 + + subroutine psb_ip_reord_e1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_epk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_epk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_e1e3 + +end module psb_e_ip_reord_mod diff --git a/base/modules/auxil/psb_e_isort_mod.f90 b/base/modules/auxil/psb_e_isort_mod.f90 new file mode 100644 index 000000000..ead8af045 --- /dev/null +++ b/base/modules/auxil/psb_e_isort_mod.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_e_isort_mod + use psb_const_mod + + interface psb_isort + subroutine psb_eisort(x,ix,dir,flag) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + end subroutine psb_eisort + end interface psb_isort + + + + interface + subroutine psi_eisrx_up(n,x,ix) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: ix(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eisrx_up + subroutine psi_eisrx_dw(n,x,ix) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: ix(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eisrx_dw + subroutine psi_eisr_up(n,x) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eisr_up + subroutine psi_eisr_dw(n,x) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eisr_dw + subroutine psi_eaisrx_up(n,x,ix) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: ix(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eaisrx_up + subroutine psi_eaisrx_dw(n,x,ix) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: ix(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eaisrx_dw + subroutine psi_eaisr_up(n,x) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eaisr_up + subroutine psi_eaisr_dw(n,x) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eaisr_dw + end interface + + +end module psb_e_isort_mod diff --git a/base/modules/auxil/psb_e_msort_mod.f90 b/base/modules/auxil/psb_e_msort_mod.f90 new file mode 100644 index 000000000..5a0758dda --- /dev/null +++ b/base/modules/auxil/psb_e_msort_mod.f90 @@ -0,0 +1,111 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_e_msort_mod + use psb_const_mod + + interface psb_isaperm + logical function psb_eisaperm(n,eip) + import + integer(psb_epk_), intent(in) :: n + integer(psb_epk_), intent(in) :: eip(n) + end function psb_eisaperm + end interface psb_isaperm + + interface psb_msort_unique + subroutine psb_emsort_u(x,nout,dir) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + end subroutine psb_emsort_u + end interface psb_msort_unique + + + interface psb_msort + subroutine psb_emsort(x,ix,dir,flag) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + end subroutine psb_emsort + end interface psb_msort + + + interface psi_msort_up + subroutine psi_e_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + end subroutine psi_e_msort_up + end interface psi_msort_up + interface psi_msort_dw + subroutine psi_e_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + end subroutine psi_e_msort_dw + end interface psi_msort_dw + interface psi_amsort_up + subroutine psi_e_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + end subroutine psi_e_amsort_up + end interface psi_amsort_up + interface psi_amsort_dw + subroutine psi_e_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + end subroutine psi_e_amsort_dw + end interface psi_amsort_dw + +end module psb_e_msort_mod diff --git a/base/modules/auxil/psb_e_qsort_mod.f90 b/base/modules/auxil/psb_e_qsort_mod.f90 new file mode 100644 index 000000000..17943bbf8 --- /dev/null +++ b/base/modules/auxil/psb_e_qsort_mod.f90 @@ -0,0 +1,123 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_e_qsort_mod + use psb_const_mod + + + + interface psb_bsrch + function psb_ebsrch(key,n,v) result(ipos) + import + integer(psb_ipk_) :: ipos, n + integer(psb_epk_) :: key + integer(psb_epk_) :: v(:) + end function psb_ebsrch + end interface psb_bsrch + + interface psb_ssrch + function psb_essrch(key,n,v) result(ipos) + import + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_epk_) :: key + integer(psb_epk_) :: v(:) + end function psb_essrch + end interface psb_ssrch + + interface psb_qsort + subroutine psb_eqsort(x,ix,dir,flag) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + end subroutine psb_eqsort + end interface psb_qsort + + interface + subroutine psi_eqsrx_up(n,x,ix) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: ix(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eqsrx_up + subroutine psi_eqsrx_dw(n,x,ix) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: ix(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eqsrx_dw + subroutine psi_eqsr_up(n,x) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eqsr_up + subroutine psi_eqsr_dw(n,x) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eqsr_dw + subroutine psi_eaqsrx_up(n,x,ix) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: ix(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eaqsrx_up + subroutine psi_eaqsrx_dw(n,x,ix) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: ix(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eaqsrx_dw + subroutine psi_eaqsr_up(n,x) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eaqsr_up + subroutine psi_eaqsr_dw(n,x) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + end subroutine psi_eaqsr_dw + end interface + +end module psb_e_qsort_mod diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 new file mode 100644 index 000000000..56e04dfba --- /dev/null +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_e_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_e_rk1 + module procedure psb_r_m_e_rk2 + module procedure psb_r_e_e_rk1 + module procedure psb_r_e_e_rk2 + module procedure psb_r_me_e_rk2 + module procedure psb_r_em_e_rk2 + + module procedure psb_r_m_2_e_rk1 + module procedure psb_r_e_2_e_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_e_rk1, psb_move_alloc_e_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_e_rk1, psb_ab_cpy_e_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_e_rk1, psb_cpy_e_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_e_rk1, psb_ensure_e_sz_e_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_e_rk1, psb_size_e_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_e_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_epk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_epk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_e_rk1 + + Subroutine psb_r_m_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + integer(psb_epk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_epk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_e_rk2 + + + Subroutine psb_r_e_e_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_epk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_epk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_e_rk1 + + Subroutine psb_r_e_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + integer(psb_epk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_epk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_e_rk2 + + Subroutine psb_r_me_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + integer(psb_epk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_epk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_e_rk2 + + Subroutine psb_r_em_e_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + integer(psb_epk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_epk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_epk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_e_rk2 + + Subroutine psb_r_m_2_e_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_e_rk1 + + Subroutine psb_r_e_2_e_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + integer(psb_epk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_e_rk1 + + + + subroutine psb_ab_cpy_e_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), allocatable, intent(in) :: vin(:) + integer(psb_epk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_e_rk1 + + subroutine psb_ab_cpy_e_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), allocatable, intent(in) :: vin(:,:) + integer(psb_epk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_e_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_e_rk2 + + + subroutine psb_cpy_e_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), intent(in) :: vin(:) + integer(psb_epk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_e_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_e_rk1 + + subroutine psb_cpy_e_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_), intent(in) :: vin(:,:) + integer(psb_epk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_e_rk2 + + + function psb_size_e_rk1(vin) result(val) + integer(psb_epk_) :: val + integer(psb_epk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_e_rk1 + + + function psb_size_e_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + integer(psb_epk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_e_rk2 + + Subroutine psb_ensure_m_sz_e_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_epk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + integer(psb_epk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_e_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_e_rk1 + + Subroutine psb_ensure_e_sz_e_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_epk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + integer(psb_epk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_e_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_e_rk1 + + Subroutine psb_move_alloc_e_rk1(vin,vout,info) + use psb_error_mod + integer(psb_epk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_e_rk1 + + Subroutine psb_move_alloc_e_rk2(vin,vout,info) + use psb_error_mod + integer(psb_epk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_e_rk2 + +end module psb_e_realloc_mod diff --git a/base/modules/auxil/psb_i_hsort_x_mod.f90 b/base/modules/auxil/psb_i_hsort_x_mod.f90 new file mode 100644 index 000000000..cf148d203 --- /dev/null +++ b/base/modules/auxil/psb_i_hsort_x_mod.f90 @@ -0,0 +1,309 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_i_hsort_x_mod + use psb_const_mod + use psb_e_hsort_mod + use psb_m_hsort_mod + + type psb_i_heap + integer(psb_ipk_) :: last, dir + integer(psb_ipk_), allocatable :: keys(:) + contains + procedure, pass(heap) :: init => psb_i_init_heap + procedure, pass(heap) :: howmany => psb_i_howmany + procedure, pass(heap) :: insert => psb_i_insert_heap + procedure, pass(heap) :: get_first => psb_i_heap_get_first + procedure, pass(heap) :: dump => psb_i_dump_heap + procedure, pass(heap) :: free => psb_i_free_heap + end type psb_i_heap + + type psb_i_idx_heap + integer(psb_ipk_) :: last, dir + integer(psb_ipk_), allocatable :: keys(:) + integer(psb_ipk_), allocatable :: idxs(:) + contains + procedure, pass(heap) :: init => psb_i_idx_init_heap + procedure, pass(heap) :: howmany => psb_i_idx_howmany + procedure, pass(heap) :: insert => psb_i_idx_insert_heap + procedure, pass(heap) :: get_first => psb_i_idx_heap_get_first + procedure, pass(heap) :: dump => psb_i_idx_dump_heap + procedure, pass(heap) :: free => psb_i_idx_free_heap + end type psb_i_idx_heap + + +contains + + subroutine psb_i_init_heap(heap,info,dir) + use psb_realloc_mod, only : psb_ensure_size + implicit none + class(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dir + + info = psb_success_ + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + call psb_ensure_size(psb_heap_resize,heap%keys,info) + + return + end subroutine psb_i_init_heap + + + function psb_i_howmany(heap) result(res) + implicit none + class(psb_i_heap), intent(in) :: heap + integer(psb_ipk_) :: res + res = heap%last + end function psb_i_howmany + + subroutine psb_i_insert_heap(key,heap,info) + use psb_realloc_mod, only : psb_ensure_size + implicit none + + integer(psb_ipk_), intent(in) :: key + class(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + if (heap%last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_heap(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_i_insert_heap + + subroutine psb_i_heap_get_first(key,heap,info) + implicit none + + class(psb_i_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: key + + + info = psb_success_ + + call psi_heap_get_first(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_i_heap_get_first + + subroutine psb_i_dump_heap(iout,heap,info) + + implicit none + class(psb_i_heap), intent(in) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iout + + info = psb_success_ + if (iout < 0) then + write(psb_err_unit,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) psb_l_init_heap + procedure, pass(heap) :: howmany => psb_l_howmany + procedure, pass(heap) :: insert => psb_l_insert_heap + procedure, pass(heap) :: get_first => psb_l_heap_get_first + procedure, pass(heap) :: dump => psb_l_dump_heap + procedure, pass(heap) :: free => psb_l_free_heap + end type psb_l_heap + + type psb_l_idx_heap + integer(psb_ipk_) :: last, dir + integer(psb_lpk_), allocatable :: keys(:) + integer(psb_lpk_), allocatable :: idxs(:) + contains + procedure, pass(heap) :: init => psb_l_idx_init_heap + procedure, pass(heap) :: howmany => psb_l_idx_howmany + procedure, pass(heap) :: insert => psb_l_idx_insert_heap + procedure, pass(heap) :: get_first => psb_l_idx_heap_get_first + procedure, pass(heap) :: dump => psb_l_idx_dump_heap + procedure, pass(heap) :: free => psb_l_idx_free_heap + end type psb_l_idx_heap + + +contains + + subroutine psb_l_init_heap(heap,info,dir) + use psb_realloc_mod, only : psb_ensure_size + implicit none + class(psb_l_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dir + + info = psb_success_ + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + call psb_ensure_size(psb_heap_resize,heap%keys,info) + + return + end subroutine psb_l_init_heap + + + function psb_l_howmany(heap) result(res) + implicit none + class(psb_l_heap), intent(in) :: heap + integer(psb_ipk_) :: res + res = heap%last + end function psb_l_howmany + + subroutine psb_l_insert_heap(key,heap,info) + use psb_realloc_mod, only : psb_ensure_size + implicit none + + integer(psb_lpk_), intent(in) :: key + class(psb_l_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + if (heap%last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_heap(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_l_insert_heap + + subroutine psb_l_heap_get_first(key,heap,info) + implicit none + + class(psb_l_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(out) :: key + + + info = psb_success_ + + call psi_heap_get_first(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_l_heap_get_first + + subroutine psb_l_dump_heap(iout,heap,info) + + implicit none + class(psb_l_heap), intent(in) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iout + + info = psb_success_ + if (iout < 0) then + write(psb_err_unit,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs) psb_l_init_heap + procedure, pass(heap) :: howmany => psb_l_howmany + procedure, pass(heap) :: insert => psb_l_insert_heap + procedure, pass(heap) :: get_first => psb_l_heap_get_first + procedure, pass(heap) :: dump => psb_l_dump_heap + procedure, pass(heap) :: free => psb_l_free_heap + end type psb_l_heap + + type psb_l_idx_heap + integer(psb_ipk_) :: last, dir + integer(psb_lpk_), allocatable :: keys(:) + integer(psb_lpk_), allocatable :: idxs(:) + contains + procedure, pass(heap) :: init => psb_l_idx_init_heap + procedure, pass(heap) :: howmany => psb_l_idx_howmany + procedure, pass(heap) :: insert => psb_l_idx_insert_heap + procedure, pass(heap) :: get_first => psb_l_idx_heap_get_first + procedure, pass(heap) :: dump => psb_l_idx_dump_heap + procedure, pass(heap) :: free => psb_l_idx_free_heap + end type psb_l_idx_heap + + + interface psb_msort + subroutine psb_lmsort(x,ix,dir,flag) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_lpk_), optional, intent(inout) :: ix(:) + end subroutine psb_lmsort + end interface psb_msort + + + interface psb_bsrch + function psb_lbsrch(key,n,v) result(ipos) + import + integer(psb_ipk_) :: ipos, n + integer(psb_lpk_) :: key + integer(psb_lpk_) :: v(:) + end function psb_lbsrch + end interface psb_bsrch + + interface psb_ssrch + function psb_lssrch(key,n,v) result(ipos) + import + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_lpk_) :: key + integer(psb_lpk_) :: v(:) + end function psb_lssrch + end interface psb_ssrch + + interface + subroutine psi_l_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_lpk_) :: k(n) + integer(psb_lpk_) :: l(0:n+1) + end subroutine psi_l_msort_up + subroutine psi_l_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_lpk_) :: k(n) + integer(psb_lpk_) :: l(0:n+1) + end subroutine psi_l_msort_dw + end interface + interface + subroutine psi_l_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_lpk_) :: k(n) + integer(psb_lpk_) :: l(0:n+1) + end subroutine psi_l_amsort_up + subroutine psi_l_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_lpk_) :: k(n) + integer(psb_lpk_) :: l(0:n+1) + end subroutine psi_l_amsort_dw + end interface + + + interface psb_qsort + subroutine psb_lqsort(x,ix,dir,flag) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_lpk_), optional, intent(inout) :: ix(:) + end subroutine psb_lqsort + end interface psb_qsort + + interface psb_isort + subroutine psb_lisort(x,ix,dir,flag) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_lpk_), optional, intent(inout) :: ix(:) + end subroutine psb_lisort + end interface psb_isort + + + interface psb_hsort + subroutine psb_lhsort(x,ix,dir,flag) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_lpk_), optional, intent(inout) :: ix(:) + end subroutine psb_lhsort + end interface psb_hsort + + + interface + subroutine psi_l_insert_heap(key,last,heap,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_lpk_), intent(in) :: key + integer(psb_lpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_l_insert_heap + end interface + + interface + subroutine psi_l_idx_insert_heap(key,index,last,heap,idxs,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_lpk_), intent(in) :: key + integer(psb_lpk_), intent(inout) :: heap(:) + integer(psb_lpk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir + integer(psb_lpk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_l_idx_insert_heap + end interface + + + interface + subroutine psi_l_heap_get_first(key,last,heap,dir,info) + import + implicit none + integer(psb_lpk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + integer(psb_lpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_l_heap_get_first + end interface + + interface + subroutine psi_l_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import + integer(psb_lpk_), intent(inout) :: key + integer(psb_lpk_), intent(out) :: index + integer(psb_lpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_lpk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_l_idx_heap_get_first + end interface + + interface + subroutine psi_lisrx_up(n,x,ix) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: ix(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_lisrx_up + subroutine psi_lisrx_dw(n,x,ix) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: ix(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_lisrx_dw + subroutine psi_lisr_up(n,x) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_lisr_up + subroutine psi_lisr_dw(n,x) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_lisr_dw + subroutine psi_laisrx_up(n,x,ix) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: ix(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_laisrx_up + subroutine psi_laisrx_dw(n,x,ix) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: ix(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_laisrx_dw + subroutine psi_laisr_up(n,x) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_laisr_up + subroutine psi_laisr_dw(n,x) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_laisr_dw + end interface + + interface + subroutine psi_lqsrx_up(n,x,ix) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: ix(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_lqsrx_up + subroutine psi_lqsrx_dw(n,x,ix) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: ix(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_lqsrx_dw + subroutine psi_lqsr_up(n,x) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_lqsr_up + subroutine psi_lqsr_dw(n,x) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_lqsr_dw + subroutine psi_laqsrx_up(n,x,ix) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: ix(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_laqsrx_up + subroutine psi_laqsrx_dw(n,x,ix) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: ix(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_laqsrx_dw + subroutine psi_laqsr_up(n,x) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_laqsr_up + subroutine psi_laqsr_dw(n,x) + import + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + end subroutine psi_laqsr_dw + end interface + +contains + + subroutine psb_l_init_heap(heap,info,dir) + use psb_realloc_mod, only : psb_ensure_size + implicit none + class(psb_l_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dir + + info = psb_success_ + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + call psb_ensure_size(psb_heap_resize,heap%keys,info) + + return + end subroutine psb_l_init_heap + + + function psb_l_howmany(heap) result(res) + implicit none + class(psb_l_heap), intent(in) :: heap + integer(psb_ipk_) :: res + res = heap%last + end function psb_l_howmany + + subroutine psb_l_insert_heap(key,heap,info) + use psb_realloc_mod, only : psb_ensure_size + implicit none + + integer(psb_lpk_), intent(in) :: key + class(psb_l_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + if (heap%last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_l_insert_heap(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_l_insert_heap + + subroutine psb_l_heap_get_first(key,heap,info) + implicit none + + class(psb_l_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(out) :: key + + + info = psb_success_ + + call psi_l_heap_get_first(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_l_heap_get_first + + subroutine psb_l_dump_heap(iout,heap,info) + + implicit none + class(psb_l_heap), intent(in) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iout + + info = psb_success_ + if (iout < 0) then + write(psb_err_unit,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs)n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1m + + subroutine psb_ip_reord_m1m1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1m1 + + subroutine psb_ip_reord_m1m2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*) + + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1m2 + + subroutine psb_ip_reord_m1m3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1m3 + + + subroutine psb_ip_reord_m1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1e + + subroutine psb_ip_reord_m1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1e1 + + subroutine psb_ip_reord_m1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1e2 + + subroutine psb_ip_reord_m1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + integer(psb_mpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + integer(psb_mpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_m1e3 + +end module psb_m_ip_reord_mod diff --git a/base/modules/auxil/psb_m_isort_mod.f90 b/base/modules/auxil/psb_m_isort_mod.f90 new file mode 100644 index 000000000..1f82f3897 --- /dev/null +++ b/base/modules/auxil/psb_m_isort_mod.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_m_isort_mod + use psb_const_mod + + interface psb_isort + subroutine psb_misort(x,ix,dir,flag) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_misort + end interface psb_isort + + + + interface + subroutine psi_misrx_up(n,x,ix) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_misrx_up + subroutine psi_misrx_dw(n,x,ix) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_misrx_dw + subroutine psi_misr_up(n,x) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_misr_up + subroutine psi_misr_dw(n,x) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_misr_dw + subroutine psi_maisrx_up(n,x,ix) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_maisrx_up + subroutine psi_maisrx_dw(n,x,ix) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_maisrx_dw + subroutine psi_maisr_up(n,x) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_maisr_up + subroutine psi_maisr_dw(n,x) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_maisr_dw + end interface + + +end module psb_m_isort_mod diff --git a/base/modules/auxil/psb_m_msort_mod.f90 b/base/modules/auxil/psb_m_msort_mod.f90 new file mode 100644 index 000000000..12a33686d --- /dev/null +++ b/base/modules/auxil/psb_m_msort_mod.f90 @@ -0,0 +1,111 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_m_msort_mod + use psb_const_mod + + interface psb_isaperm + logical function psb_misaperm(n,eip) + import + integer(psb_mpk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: eip(n) + end function psb_misaperm + end interface psb_isaperm + + interface psb_msort_unique + subroutine psb_mmsort_u(x,nout,dir) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + end subroutine psb_mmsort_u + end interface psb_msort_unique + + + interface psb_msort + subroutine psb_mmsort(x,ix,dir,flag) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_mmsort + end interface psb_msort + + + interface psi_msort_up + subroutine psi_m_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_m_msort_up + end interface psi_msort_up + interface psi_msort_dw + subroutine psi_m_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_m_msort_dw + end interface psi_msort_dw + interface psi_amsort_up + subroutine psi_m_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_m_amsort_up + end interface psi_amsort_up + interface psi_amsort_dw + subroutine psi_m_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_m_amsort_dw + end interface psi_amsort_dw + +end module psb_m_msort_mod diff --git a/base/modules/auxil/psb_m_qsort_mod.f90 b/base/modules/auxil/psb_m_qsort_mod.f90 new file mode 100644 index 000000000..cb4c81c1d --- /dev/null +++ b/base/modules/auxil/psb_m_qsort_mod.f90 @@ -0,0 +1,123 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_m_qsort_mod + use psb_const_mod + + + + interface psb_bsrch + function psb_mbsrch(key,n,v) result(ipos) + import + integer(psb_ipk_) :: ipos, n + integer(psb_mpk_) :: key + integer(psb_mpk_) :: v(:) + end function psb_mbsrch + end interface psb_bsrch + + interface psb_ssrch + function psb_mssrch(key,n,v) result(ipos) + import + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_mpk_) :: key + integer(psb_mpk_) :: v(:) + end function psb_mssrch + end interface psb_ssrch + + interface psb_qsort + subroutine psb_mqsort(x,ix,dir,flag) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_mqsort + end interface psb_qsort + + interface + subroutine psi_mqsrx_up(n,x,ix) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_mqsrx_up + subroutine psi_mqsrx_dw(n,x,ix) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_mqsrx_dw + subroutine psi_mqsr_up(n,x) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_mqsr_up + subroutine psi_mqsr_dw(n,x) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_mqsr_dw + subroutine psi_maqsrx_up(n,x,ix) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_maqsrx_up + subroutine psi_maqsrx_dw(n,x,ix) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_maqsrx_dw + subroutine psi_maqsr_up(n,x) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_maqsr_up + subroutine psi_maqsr_dw(n,x) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_maqsr_dw + end interface + +end module psb_m_qsort_mod diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 new file mode 100644 index 000000000..993be5713 --- /dev/null +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_m_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_m_rk1 + module procedure psb_r_m_m_rk2 + module procedure psb_r_e_m_rk1 + module procedure psb_r_e_m_rk2 + module procedure psb_r_me_m_rk2 + module procedure psb_r_em_m_rk2 + + module procedure psb_r_m_2_m_rk1 + module procedure psb_r_e_2_m_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_m_rk1, psb_move_alloc_m_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_m_rk1, psb_ab_cpy_m_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_m_rk1, psb_cpy_m_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_m_rk1, psb_ensure_e_sz_m_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_m_rk1, psb_size_m_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_m_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_mpk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_m_rk1 + + Subroutine psb_r_m_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + integer(psb_mpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_mpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_m_rk2 + + + Subroutine psb_r_e_m_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_mpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + integer(psb_mpk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_m_rk1 + + Subroutine psb_r_e_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + integer(psb_mpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_mpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_m_rk2 + + Subroutine psb_r_me_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + integer(psb_mpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_mpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_m_rk2 + + Subroutine psb_r_em_m_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + integer(psb_mpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + integer(psb_mpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='integer(psb_mpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_m_rk2 + + Subroutine psb_r_m_2_m_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_m_rk1 + + Subroutine psb_r_e_2_m_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + integer(psb_mpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_m_rk1 + + + + subroutine psb_ab_cpy_m_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), allocatable, intent(in) :: vin(:) + integer(psb_mpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_m_rk1 + + subroutine psb_ab_cpy_m_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), allocatable, intent(in) :: vin(:,:) + integer(psb_mpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_m_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_m_rk2 + + + subroutine psb_cpy_m_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), intent(in) :: vin(:) + integer(psb_mpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_m_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_m_rk1 + + subroutine psb_cpy_m_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_), intent(in) :: vin(:,:) + integer(psb_mpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_m_rk2 + + + function psb_size_m_rk1(vin) result(val) + integer(psb_epk_) :: val + integer(psb_mpk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_m_rk1 + + + function psb_size_m_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + integer(psb_mpk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_m_rk2 + + Subroutine psb_ensure_m_sz_m_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + integer(psb_mpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + integer(psb_mpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_m_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_m_rk1 + + Subroutine psb_ensure_e_sz_m_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + integer(psb_mpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + integer(psb_mpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_m_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_m_rk1 + + Subroutine psb_move_alloc_m_rk1(vin,vout,info) + use psb_error_mod + integer(psb_mpk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_m_rk1 + + Subroutine psb_move_alloc_m_rk2(vin,vout,info) + use psb_error_mod + integer(psb_mpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_m_rk2 + +end module psb_m_realloc_mod diff --git a/base/modules/auxil/psb_s_hsort_mod.f90 b/base/modules/auxil/psb_s_hsort_mod.f90 new file mode 100644 index 000000000..3d30bafdd --- /dev/null +++ b/base/modules/auxil/psb_s_hsort_mod.f90 @@ -0,0 +1,125 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_s_hsort_mod + use psb_const_mod + + interface psb_hsort + subroutine psb_shsort(x,ix,dir,flag) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_shsort + end interface psb_hsort + + + interface psi_insert_heap + subroutine psi_s_insert_heap(key,last,heap,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + real(psb_spk_), intent(in) :: key + real(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_s_insert_heap + end interface psi_insert_heap + + interface psi_idx_insert_heap + subroutine psi_s_idx_insert_heap(key,index,last,heap,idxs,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + real(psb_spk_), intent(in) :: key + real(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_s_idx_insert_heap + end interface psi_idx_insert_heap + + + interface psi_heap_get_first + subroutine psi_s_heap_get_first(key,last,heap,dir,info) + import + implicit none + real(psb_spk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + real(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_s_heap_get_first + end interface psi_heap_get_first + + interface psi_idx_heap_get_first + subroutine psi_s_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import + real(psb_spk_), intent(inout) :: key + integer(psb_ipk_), intent(out) :: index + real(psb_spk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_s_idx_heap_get_first + end interface psi_idx_heap_get_first + + +end module psb_s_hsort_mod diff --git a/base/modules/auxil/psb_s_hsort_x_mod.f90 b/base/modules/auxil/psb_s_hsort_x_mod.f90 new file mode 100644 index 000000000..3b395fb10 --- /dev/null +++ b/base/modules/auxil/psb_s_hsort_x_mod.f90 @@ -0,0 +1,308 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_s_hsort_x_mod + use psb_const_mod + use psb_s_hsort_mod + + type psb_s_heap + integer(psb_ipk_) :: last, dir + real(psb_spk_), allocatable :: keys(:) + contains + procedure, pass(heap) :: init => psb_s_init_heap + procedure, pass(heap) :: howmany => psb_s_howmany + procedure, pass(heap) :: insert => psb_s_insert_heap + procedure, pass(heap) :: get_first => psb_s_heap_get_first + procedure, pass(heap) :: dump => psb_s_dump_heap + procedure, pass(heap) :: free => psb_s_free_heap + end type psb_s_heap + + type psb_s_idx_heap + integer(psb_ipk_) :: last, dir + real(psb_spk_), allocatable :: keys(:) + integer(psb_ipk_), allocatable :: idxs(:) + contains + procedure, pass(heap) :: init => psb_s_idx_init_heap + procedure, pass(heap) :: howmany => psb_s_idx_howmany + procedure, pass(heap) :: insert => psb_s_idx_insert_heap + procedure, pass(heap) :: get_first => psb_s_idx_heap_get_first + procedure, pass(heap) :: dump => psb_s_idx_dump_heap + procedure, pass(heap) :: free => psb_s_idx_free_heap + end type psb_s_idx_heap + + +contains + + subroutine psb_s_init_heap(heap,info,dir) + use psb_realloc_mod, only : psb_ensure_size + implicit none + class(psb_s_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dir + + info = psb_success_ + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_sort_up_ + endif + select case(heap%dir) + case (psb_sort_up_,psb_sort_down_,psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(psb_err_unit,*) 'Invalid direction, defaulting to psb_sort_up_' + heap%dir = psb_sort_up_ + end select + call psb_ensure_size(psb_heap_resize,heap%keys,info) + + return + end subroutine psb_s_init_heap + + + function psb_s_howmany(heap) result(res) + implicit none + class(psb_s_heap), intent(in) :: heap + integer(psb_ipk_) :: res + res = heap%last + end function psb_s_howmany + + subroutine psb_s_insert_heap(key,heap,info) + use psb_realloc_mod, only : psb_ensure_size + implicit none + + real(psb_spk_), intent(in) :: key + class(psb_s_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + if (heap%last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_heap(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_s_insert_heap + + subroutine psb_s_heap_get_first(key,heap,info) + implicit none + + class(psb_s_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), intent(out) :: key + + + info = psb_success_ + + call psi_heap_get_first(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_s_heap_get_first + + subroutine psb_s_dump_heap(iout,heap,info) + + implicit none + class(psb_s_heap), intent(in) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iout + + info = psb_success_ + if (iout < 0) then + write(psb_err_unit,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs)n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1m + + subroutine psb_ip_reord_s1m1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1m1 + + subroutine psb_ip_reord_s1m2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*) + + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1m2 + + subroutine psb_ip_reord_s1m3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1m3 + + + subroutine psb_ip_reord_s1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1e + + subroutine psb_ip_reord_s1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1e1 + + subroutine psb_ip_reord_s1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1e2 + + subroutine psb_ip_reord_s1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + real(psb_spk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + real(psb_spk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_s1e3 + +end module psb_s_ip_reord_mod diff --git a/base/modules/auxil/psb_s_isort_mod.f90 b/base/modules/auxil/psb_s_isort_mod.f90 new file mode 100644 index 000000000..9692ed88b --- /dev/null +++ b/base/modules/auxil/psb_s_isort_mod.f90 @@ -0,0 +1,105 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_s_isort_mod + use psb_const_mod + + interface psb_isort + subroutine psb_sisort(x,ix,dir,flag) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_sisort + end interface psb_isort + + + + interface + subroutine psi_sisrx_up(n,x,ix) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_sisrx_up + subroutine psi_sisrx_dw(n,x,ix) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_sisrx_dw + subroutine psi_sisr_up(n,x) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_sisr_up + subroutine psi_sisr_dw(n,x) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_sisr_dw + subroutine psi_saisrx_up(n,x,ix) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_saisrx_up + subroutine psi_saisrx_dw(n,x,ix) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_saisrx_dw + subroutine psi_saisr_up(n,x) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_saisr_up + subroutine psi_saisr_dw(n,x) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_saisr_dw + end interface + + +end module psb_s_isort_mod diff --git a/base/modules/auxil/psb_s_msort_mod.f90 b/base/modules/auxil/psb_s_msort_mod.f90 new file mode 100644 index 000000000..f31072905 --- /dev/null +++ b/base/modules/auxil/psb_s_msort_mod.f90 @@ -0,0 +1,104 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_s_msort_mod + use psb_const_mod + + + interface psb_msort_unique + subroutine psb_smsort_u(x,nout,dir) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + end subroutine psb_smsort_u + end interface psb_msort_unique + + + interface psb_msort + subroutine psb_smsort(x,ix,dir,flag) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_smsort + end interface psb_msort + + + interface psi_msort_up + subroutine psi_s_msort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_s_msort_up + end interface psi_msort_up + interface psi_msort_dw + subroutine psi_s_msort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_s_msort_dw + end interface psi_msort_dw + interface psi_amsort_up + subroutine psi_s_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_s_amsort_up + end interface psi_amsort_up + interface psi_amsort_dw + subroutine psi_s_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + real(psb_spk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_s_amsort_dw + end interface psi_amsort_dw + +end module psb_s_msort_mod diff --git a/base/modules/auxil/psb_s_qsort_mod.f90 b/base/modules/auxil/psb_s_qsort_mod.f90 new file mode 100644 index 000000000..d4851fd1b --- /dev/null +++ b/base/modules/auxil/psb_s_qsort_mod.f90 @@ -0,0 +1,123 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_s_qsort_mod + use psb_const_mod + + + + interface psb_bsrch + function psb_sbsrch(key,n,v) result(ipos) + import + integer(psb_ipk_) :: ipos, n + real(psb_spk_) :: key + real(psb_spk_) :: v(:) + end function psb_sbsrch + end interface psb_bsrch + + interface psb_ssrch + function psb_sssrch(key,n,v) result(ipos) + import + implicit none + integer(psb_ipk_) :: ipos, n + real(psb_spk_) :: key + real(psb_spk_) :: v(:) + end function psb_sssrch + end interface psb_ssrch + + interface psb_qsort + subroutine psb_sqsort(x,ix,dir,flag) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_sqsort + end interface psb_qsort + + interface + subroutine psi_sqsrx_up(n,x,ix) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_sqsrx_up + subroutine psi_sqsrx_dw(n,x,ix) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_sqsrx_dw + subroutine psi_sqsr_up(n,x) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_sqsr_up + subroutine psi_sqsr_dw(n,x) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_sqsr_dw + subroutine psi_saqsrx_up(n,x,ix) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_saqsrx_up + subroutine psi_saqsrx_dw(n,x,ix) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_saqsrx_dw + subroutine psi_saqsr_up(n,x) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_saqsr_up + subroutine psi_saqsr_dw(n,x) + import + real(psb_spk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_saqsr_dw + end interface + +end module psb_s_qsort_mod diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 new file mode 100644 index 000000000..4d29a28a7 --- /dev/null +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_s_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_s_rk1 + module procedure psb_r_m_s_rk2 + module procedure psb_r_e_s_rk1 + module procedure psb_r_e_s_rk2 + module procedure psb_r_me_s_rk2 + module procedure psb_r_em_s_rk2 + + module procedure psb_r_m_2_s_rk1 + module procedure psb_r_e_2_s_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_s_rk1, psb_move_alloc_s_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_s_rk1, psb_ab_cpy_s_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_s_rk1, psb_cpy_s_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_s_rk1, psb_ensure_e_sz_s_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_s_rk1, psb_size_s_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_s_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + real(psb_spk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + real(psb_spk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_s_rk1 + + Subroutine psb_r_m_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_s_rk2 + + + Subroutine psb_r_e_s_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + real(psb_spk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + real(psb_spk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_s_rk1 + + Subroutine psb_r_e_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_s_rk2 + + Subroutine psb_r_me_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_s_rk2 + + Subroutine psb_r_em_s_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + real(psb_spk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + real(psb_spk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_s_rk2 + + Subroutine psb_r_m_2_s_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_s_rk1 + + Subroutine psb_r_e_2_s_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + real(psb_spk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_s_rk1 + + + + subroutine psb_ab_cpy_s_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), allocatable, intent(in) :: vin(:) + real(psb_spk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_s_rk1 + + subroutine psb_ab_cpy_s_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), allocatable, intent(in) :: vin(:,:) + real(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_s_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_s_rk2 + + + subroutine psb_cpy_s_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), intent(in) :: vin(:) + real(psb_spk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_s_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_s_rk1 + + subroutine psb_cpy_s_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + real(psb_spk_), intent(in) :: vin(:,:) + real(psb_spk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_s_rk2 + + + function psb_size_s_rk1(vin) result(val) + integer(psb_epk_) :: val + real(psb_spk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_s_rk1 + + + function psb_size_s_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + real(psb_spk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_s_rk2 + + Subroutine psb_ensure_m_sz_s_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + real(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_s_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_s_rk1 + + Subroutine psb_ensure_e_sz_s_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + real(psb_spk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + real(psb_spk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_s_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_s_rk1 + + Subroutine psb_move_alloc_s_rk1(vin,vout,info) + use psb_error_mod + real(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_s_rk1 + + Subroutine psb_move_alloc_s_rk2(vin,vout,info) + use psb_error_mod + real(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_s_rk2 + +end module psb_s_realloc_mod diff --git a/base/modules/aux/psb_s_sort_mod.f90 b/base/modules/auxil/psb_s_sort_mod.f90 similarity index 99% rename from base/modules/aux/psb_s_sort_mod.f90 rename to base/modules/auxil/psb_s_sort_mod.f90 index 6eeeb2e3d..92be88839 100644 --- a/base/modules/aux/psb_s_sort_mod.f90 +++ b/base/modules/auxil/psb_s_sort_mod.f90 @@ -44,6 +44,8 @@ module psb_s_sort_mod use psb_const_mod + @INTE@ + interface psb_msort_unique subroutine psb_smsort_u(x,nout,dir) import @@ -515,7 +517,8 @@ contains implicit none class(psb_s_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info real(psb_spk_), intent(out) :: key diff --git a/base/modules/auxil/psb_sort_mod.f90 b/base/modules/auxil/psb_sort_mod.f90 new file mode 100644 index 000000000..0bd7bdfc4 --- /dev/null +++ b/base/modules/auxil/psb_sort_mod.f90 @@ -0,0 +1,86 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The merge-sort and quicksort routines are implemented in the +! serial/aux directory +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! + +module psb_sort_mod + use psb_const_mod + use psb_ip_reord_mod + + use psb_m_hsort_mod + use psb_m_isort_mod + use psb_m_msort_mod + use psb_m_qsort_mod + + use psb_e_hsort_mod + use psb_e_isort_mod + use psb_e_msort_mod + use psb_e_qsort_mod + + use psb_s_hsort_mod + use psb_s_isort_mod + use psb_s_msort_mod + use psb_s_qsort_mod + + use psb_d_hsort_mod + use psb_d_isort_mod + use psb_d_msort_mod + use psb_d_qsort_mod + + use psb_c_hsort_mod + use psb_c_isort_mod + use psb_c_msort_mod + use psb_c_qsort_mod + + use psb_z_hsort_mod + use psb_z_isort_mod + use psb_z_msort_mod + use psb_z_qsort_mod + + use psb_i_hsort_x_mod + use psb_l_hsort_x_mod + use psb_s_hsort_x_mod + use psb_d_hsort_x_mod + use psb_c_hsort_x_mod + use psb_z_hsort_x_mod + +end module psb_sort_mod diff --git a/base/modules/aux/psb_string_mod.f90 b/base/modules/auxil/psb_string_mod.f90 similarity index 100% rename from base/modules/aux/psb_string_mod.f90 rename to base/modules/auxil/psb_string_mod.f90 diff --git a/base/modules/auxil/psb_z_hsort_mod.f90 b/base/modules/auxil/psb_z_hsort_mod.f90 new file mode 100644 index 000000000..573eef6b9 --- /dev/null +++ b/base/modules/auxil/psb_z_hsort_mod.f90 @@ -0,0 +1,125 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_z_hsort_mod + use psb_const_mod + + interface psb_hsort + subroutine psb_zhsort(x,ix,dir,flag) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_zhsort + end interface psb_hsort + + + interface psi_insert_heap + subroutine psi_z_insert_heap(key,last,heap,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + complex(psb_dpk_), intent(in) :: key + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_z_insert_heap + end interface psi_insert_heap + + interface psi_idx_insert_heap + subroutine psi_z_idx_insert_heap(key,index,last,heap,idxs,dir,info) + import + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + complex(psb_dpk_), intent(in) :: key + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: index + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + end subroutine psi_z_idx_insert_heap + end interface psi_idx_insert_heap + + + interface psi_heap_get_first + subroutine psi_z_heap_get_first(key,last,heap,dir,info) + import + implicit none + complex(psb_dpk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_z_heap_get_first + end interface psi_heap_get_first + + interface psi_idx_heap_get_first + subroutine psi_z_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + import + complex(psb_dpk_), intent(inout) :: key + integer(psb_ipk_), intent(out) :: index + complex(psb_dpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(inout) :: idxs(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_z_idx_heap_get_first + end interface psi_idx_heap_get_first + + +end module psb_z_hsort_mod diff --git a/base/modules/auxil/psb_z_hsort_x_mod.f90 b/base/modules/auxil/psb_z_hsort_x_mod.f90 new file mode 100644 index 000000000..fc0edd9b0 --- /dev/null +++ b/base/modules/auxil/psb_z_hsort_x_mod.f90 @@ -0,0 +1,308 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_z_hsort_x_mod + use psb_const_mod + use psb_z_hsort_mod + + type psb_z_heap + integer(psb_ipk_) :: last, dir + complex(psb_dpk_), allocatable :: keys(:) + contains + procedure, pass(heap) :: init => psb_z_init_heap + procedure, pass(heap) :: howmany => psb_z_howmany + procedure, pass(heap) :: insert => psb_z_insert_heap + procedure, pass(heap) :: get_first => psb_z_heap_get_first + procedure, pass(heap) :: dump => psb_z_dump_heap + procedure, pass(heap) :: free => psb_z_free_heap + end type psb_z_heap + + type psb_z_idx_heap + integer(psb_ipk_) :: last, dir + complex(psb_dpk_), allocatable :: keys(:) + integer(psb_ipk_), allocatable :: idxs(:) + contains + procedure, pass(heap) :: init => psb_z_idx_init_heap + procedure, pass(heap) :: howmany => psb_z_idx_howmany + procedure, pass(heap) :: insert => psb_z_idx_insert_heap + procedure, pass(heap) :: get_first => psb_z_idx_heap_get_first + procedure, pass(heap) :: dump => psb_z_idx_dump_heap + procedure, pass(heap) :: free => psb_z_idx_free_heap + end type psb_z_idx_heap + + +contains + + subroutine psb_z_init_heap(heap,info,dir) + use psb_realloc_mod, only : psb_ensure_size + implicit none + class(psb_z_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: dir + + info = psb_success_ + heap%last=0 + if (present(dir)) then + heap%dir = dir + else + heap%dir = psb_asort_up_ + endif + select case(heap%dir) + case (psb_asort_up_,psb_asort_down_) + ! ok, do nothing + case default + write(psb_err_unit,*) 'Invalid direction, defaulting to psb_asort_up_' + heap%dir = psb_asort_up_ + end select + call psb_ensure_size(psb_heap_resize,heap%keys,info) + + return + end subroutine psb_z_init_heap + + + function psb_z_howmany(heap) result(res) + implicit none + class(psb_z_heap), intent(in) :: heap + integer(psb_ipk_) :: res + res = heap%last + end function psb_z_howmany + + subroutine psb_z_insert_heap(key,heap,info) + use psb_realloc_mod, only : psb_ensure_size + implicit none + + complex(psb_dpk_), intent(in) :: key + class(psb_z_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + if (heap%last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',heap%last + info = heap%last + return + endif + + call psb_ensure_size(heap%last+1,heap%keys,info,addsz=psb_heap_resize) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Memory allocation failure in heap_insert' + info = -5 + return + end if + call psi_insert_heap(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_z_insert_heap + + subroutine psb_z_heap_get_first(key,heap,info) + implicit none + + class(psb_z_heap), intent(inout) :: heap + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), intent(out) :: key + + + info = psb_success_ + + call psi_heap_get_first(key,& + & heap%last,heap%keys,heap%dir,info) + + return + end subroutine psb_z_heap_get_first + + subroutine psb_z_dump_heap(iout,heap,info) + + implicit none + class(psb_z_heap), intent(in) :: heap + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iout + + info = psb_success_ + if (iout < 0) then + write(psb_err_unit,*) 'Invalid file ' + info =-1 + return + end if + + write(iout,*) 'Heap direction ',heap%dir + write(iout,*) 'Heap size ',heap%last + if ((heap%last > 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%keys)).or.& + & (size(heap%keys) 0).and.((.not.allocated(heap%idxs)).or.& + & (size(heap%idxs)n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1m + + subroutine psb_ip_reord_z1m1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_mpk_) :: indx(*) + integer(psb_mpk_) :: lswap, lp, k, ixswap + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1m1 + + subroutine psb_ip_reord_z1m2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*) + + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2 + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1m2 + + subroutine psb_ip_reord_z1m3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_mpk_) :: i1(*), i2(*), i3(*) + + integer(psb_mpk_) :: lswap, lp, k, isw1, isw2, isw3 + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1m3 + + + subroutine psb_ip_reord_z1e(n,x,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_epk_) :: lswap, lp, k + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1e + + subroutine psb_ip_reord_z1e1(n,x,indx,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_epk_) :: indx(*) + integer(psb_epk_) :: lswap, lp, k, ixswap + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + ixswap = indx(lp) + indx(lp) = indx(k) + indx(k) = ixswap + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1e1 + + subroutine psb_ip_reord_z1e2(n,x,i1,i2,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*) + + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2 + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1e2 + + subroutine psb_ip_reord_z1e3(n,x,i1,i2,i3,iaux) + integer(psb_ipk_), intent(in) :: n + integer(psb_epk_) :: iaux(0:*) + complex(psb_dpk_) :: x(*) + integer(psb_epk_) :: i1(*), i2(*), i3(*) + + integer(psb_epk_) :: lswap, lp, k, isw1, isw2, isw3 + complex(psb_dpk_) :: swap + + lp = iaux(0) + k = 1 + do + if ((lp == 0).or.(k>n)) exit + do + if (lp >= k) exit + lp = iaux(lp) + end do + swap = x(lp) + x(lp) = x(k) + x(k) = swap + isw1 = i1(lp) + i1(lp) = i1(k) + i1(k) = isw1 + isw2 = i2(lp) + i2(lp) = i2(k) + i2(k) = isw2 + isw3 = i3(lp) + i3(lp) = i3(k) + i3(k) = isw3 + lswap = iaux(lp) + iaux(lp) = iaux(k) + iaux(k) = lp + lp = lswap + k = k + 1 + enddo + return + end subroutine psb_ip_reord_z1e3 + +end module psb_z_ip_reord_mod diff --git a/base/modules/auxil/psb_z_isort_mod.f90 b/base/modules/auxil/psb_z_isort_mod.f90 new file mode 100644 index 000000000..4048088a9 --- /dev/null +++ b/base/modules/auxil/psb_z_isort_mod.f90 @@ -0,0 +1,127 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_z_isort_mod + use psb_const_mod + + interface psb_isort + subroutine psb_zisort(x,ix,dir,flag) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_zisort + end interface psb_isort + + + + interface + subroutine psi_zlisrx_up(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zlisrx_up + subroutine psi_zlisrx_dw(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zlisrx_dw + subroutine psi_zlisr_up(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zlisr_up + subroutine psi_zlisr_dw(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zlisr_dw + subroutine psi_zalisrx_up(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zalisrx_up + subroutine psi_zalisrx_dw(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zalisrx_dw + subroutine psi_zalisr_up(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zalisr_up + subroutine psi_zalisr_dw(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zalisr_dw + subroutine psi_zaisrx_up(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zaisrx_up + subroutine psi_zaisrx_dw(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zaisrx_dw + subroutine psi_zaisr_up(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zaisr_up + subroutine psi_zaisr_dw(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zaisr_dw + end interface + + +end module psb_z_isort_mod diff --git a/base/modules/auxil/psb_z_msort_mod.f90 b/base/modules/auxil/psb_z_msort_mod.f90 new file mode 100644 index 000000000..515b69cf1 --- /dev/null +++ b/base/modules/auxil/psb_z_msort_mod.f90 @@ -0,0 +1,121 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_z_msort_mod + use psb_const_mod + + + interface psb_msort_unique + subroutine psb_zmsort_u(x,nout,dir) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + end subroutine psb_zmsort_u + end interface psb_msort_unique + + + interface psb_msort + subroutine psb_zmsort(x,ix,dir,flag) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_zmsort + end interface psb_msort + + interface psi_lmsort_up + subroutine psi_z_lmsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_lmsort_up + end interface psi_lmsort_up + interface psi_lmsort_dw + subroutine psi_z_lmsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_lmsort_dw + end interface psi_lmsort_dw + interface psi_almsort_up + subroutine psi_z_almsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_almsort_up + end interface psi_almsort_up + interface psi_almsort_dw + subroutine psi_z_almsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_almsort_dw + end interface psi_almsort_dw + interface psi_amsort_up + subroutine psi_z_amsort_up(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_amsort_up + end interface psi_amsort_up + interface psi_amsort_dw + subroutine psi_z_amsort_dw(n,k,l,iret) + import + implicit none + integer(psb_ipk_) :: n, iret + complex(psb_dpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + end subroutine psi_z_amsort_dw + end interface psi_amsort_dw + +end module psb_z_msort_mod diff --git a/base/modules/auxil/psb_z_qsort_mod.f90 b/base/modules/auxil/psb_z_qsort_mod.f90 new file mode 100644 index 000000000..14ee0c57d --- /dev/null +++ b/base/modules/auxil/psb_z_qsort_mod.f90 @@ -0,0 +1,126 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! Sorting routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +module psb_z_qsort_mod + use psb_const_mod + + + + interface psb_qsort + subroutine psb_zqsort(x,ix,dir,flag) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + end subroutine psb_zqsort + end interface psb_qsort + + interface + subroutine psi_zlqsrx_up(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zlqsrx_up + subroutine psi_zlqsrx_dw(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zlqsrx_dw + subroutine psi_zlqsr_up(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zlqsr_up + subroutine psi_zlqsr_dw(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zlqsr_dw + subroutine psi_zalqsrx_up(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zalqsrx_up + subroutine psi_zalqsrx_dw(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zalqsrx_dw + subroutine psi_zalqsr_up(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zalqsr_up + subroutine psi_zalqsr_dw(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zalqsr_dw + subroutine psi_zaqsrx_up(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zaqsrx_up + subroutine psi_zaqsrx_dw(n,x,ix) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: ix(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zaqsrx_dw + subroutine psi_zaqsr_up(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zaqsr_up + subroutine psi_zaqsr_dw(n,x) + import + complex(psb_dpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + end subroutine psi_zaqsr_dw + end interface + +end module psb_z_qsort_mod diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 new file mode 100644 index 000000000..bf849a1e3 --- /dev/null +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -0,0 +1,1027 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_z_realloc_mod + use psb_const_mod + + implicit none + + ! + ! psb_realloc will reallocate the input array to have exactly + ! the size specified, possibly shortening it. + ! + Interface psb_realloc + module procedure psb_r_m_z_rk1 + module procedure psb_r_m_z_rk2 + module procedure psb_r_e_z_rk1 + module procedure psb_r_e_z_rk2 + module procedure psb_r_me_z_rk2 + module procedure psb_r_em_z_rk2 + + module procedure psb_r_m_2_z_rk1 + module procedure psb_r_e_2_z_rk1 + + end Interface psb_realloc + + interface psb_move_alloc + module procedure psb_move_alloc_z_rk1, psb_move_alloc_z_rk2 + end interface psb_move_alloc + + Interface psb_safe_ab_cpy + module procedure psb_ab_cpy_z_rk1, psb_ab_cpy_z_rk2 + end Interface psb_safe_ab_cpy + + Interface psb_safe_cpy + module procedure psb_cpy_z_rk1, psb_cpy_z_rk2 + end Interface psb_safe_cpy + + ! + ! psb_ensure_size will reallocate the input array if necessary + ! to guarantee that its size is at least as large as the + ! value required, usually with some room to spare. + ! + interface psb_ensure_size + module procedure psb_ensure_m_sz_z_rk1, psb_ensure_e_sz_z_rk1 + end Interface psb_ensure_size + + ! + ! psb_size returns 0 if argument is not allocated. + ! + interface psb_size + module procedure psb_size_z_rk1, psb_size_z_rk2 + end interface psb_size + + +Contains + + Subroutine psb_r_m_z_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + complex(psb_dpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_), optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_dpk_),allocatable :: tmp(:) + integer(psb_mpk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_z_rk1 + + Subroutine psb_r_m_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1,len2 + complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err + integer(psb_mpk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_m_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + call psb_errpush(err,name, l_err=(/len2*1_psb_lpk_/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + call psb_errpush(err,name, l_err=(/len1*1_psb_lpk_*len2/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_m_z_rk2 + + + Subroutine psb_r_e_z_rk1(len,rrax,info,pad,lb) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + complex(psb_dpk_), allocatable, intent(inout) :: rrax(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_epk_), optional, intent(in) :: lb + + ! ...Local Variables + complex(psb_dpk_),allocatable :: tmp(:) + integer(psb_epk_) :: dim, lb_, lbi,ub_ + integer(psb_ipk_) :: iplen + integer(psb_ipk_) :: err_act,err + character(len=20) :: name + logical, parameter :: debug=.false. + + name='psb_r_m_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if (debug) write(psb_err_unit,*) 'reallocate D',len + + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + if ((len<0)) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + ub_ = lb_ + len-1 + + if (allocated(rrax)) then + dim = size(rrax) + lbi = lbound(rrax,1) + If ((dim /= len).or.(lbi /= lb_)) Then + Allocate(tmp(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + Allocate(rrax(lb_:ub_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb_-1+dim+1:lb_-1+len) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_z_rk1 + + Subroutine psb_r_e_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1,len2 + complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_epk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_epk_) :: dim,dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + character(len=20) :: name + + name='psb_r_e_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_e_z_rk2 + + Subroutine psb_r_me_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len1 + integer(psb_epk_),Intent(in) :: len2 + complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim2 + character(len=20) :: name + + name='psb_r_me_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name,i_err=(/iplen/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_me_z_rk2 + + Subroutine psb_r_em_z_rk2(len1,len2,rrax,info,pad,lb1,lb2) + use psb_error_mod + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len1 + integer(psb_mpk_),Intent(in) :: len2 + complex(psb_dpk_),allocatable :: rrax(:,:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + integer(psb_mpk_),Intent(in), optional :: lb1,lb2 + + ! ...Local Variables + + complex(psb_dpk_),allocatable :: tmp(:,:) + integer(psb_ipk_) :: err_act,err, iplen + integer(psb_mpk_) :: dim2,lb1_, lb2_, ub1_, ub2_,lbi1, lbi2 + integer(psb_epk_) :: dim + character(len=20) :: name + + name='psb_r_me_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if (present(lb1)) then + lb1_ = lb1 + else + lb1_ = 1 + endif + if (present(lb2)) then + lb2_ = lb2 + else + lb2_ = 1 + endif + ub1_ = lb1_ + len1 -1 + ub2_ = lb2_ + len2 -1 + + if (len1 < 0) then + err=4025 + iplen = len1 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + if (len2 < 0) then + err=4025 + iplen = len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + + if (allocated(rrax)) then + dim = size(rrax,1) + lbi1 = lbound(rrax,1) + dim2 = size(rrax,2) + lbi2 = lbound(rrax,2) + If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& + & .or.(lbi2 /= lb2_)) Then + Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & + & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) + call psb_move_alloc(tmp,rrax,info) + End If + else + dim = 0 + dim2 = 0 + Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) + if (info /= psb_success_) then + err=4025 + iplen = len1*len2 + call psb_errpush(err,name, i_err=(/iplen/), & + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + if (present(pad)) then + rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad + rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad + endif + call psb_erractionrestore(err_act) + return + +9999 continue + info = err + call psb_error_handler(err_act) + return + + End Subroutine psb_r_em_z_rk2 + + Subroutine psb_r_m_2_z_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_mpk_),Intent(in) :: len + complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_m_2_z_rk1 + + Subroutine psb_r_e_2_z_rk1(len,rrax,y,info,pad) + use psb_error_mod + ! ...Subroutine Arguments + + integer(psb_epk_),Intent(in) :: len + complex(psb_dpk_),allocatable, intent(inout) :: rrax(:),y(:) + integer(psb_ipk_) :: info + complex(psb_dpk_), optional, intent(in) :: pad + character(len=20) :: name + integer(psb_ipk_) :: err_act, err + + name='psb_r_m_2_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + call psb_realloc(len,rrax,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_realloc(len,y,info,pad=pad) + if (info /= psb_success_) then + err=4000 + call psb_errpush(err,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + End Subroutine psb_r_e_2_z_rk1 + + + + subroutine psb_ab_cpy_z_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), allocatable, intent(in) :: vin(:) + complex(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_z_rk1 + + subroutine psb_ab_cpy_z_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) + complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_ab_cpy_z_rk2' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + if (allocated(vin)) then + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_ab_cpy_z_rk2 + + + subroutine psb_cpy_z_rk1(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), intent(in) :: vin(:) + complex(psb_dpk_), allocatable, intent(out) :: vout(:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz,err_act,lb + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_cpy_z_rk1' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + isz = size(vin) + lb = lbound(vin,1) + call psb_realloc(isz,vout,info,lb=lb) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:) = vin(:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_z_rk1 + + subroutine psb_cpy_z_rk2(vin,vout,info) + use psb_error_mod + + ! ...Subroutine Arguments + complex(psb_dpk_), intent(in) :: vin(:,:) + complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) + integer(psb_ipk_) :: info + ! ...Local Variables + + integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 + character(len=20) :: name, char_err + logical, parameter :: debug=.false. + + name='psb_safe_cpy' + call psb_erractionsave(err_act) + info=psb_success_ + if(psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + isz1 = size(vin,1) + isz2 = size(vin,2) + lb1 = lbound(vin,1) + lb2 = lbound(vin,2) + call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + char_err='psb_realloc' + call psb_errpush(info,name,a_err=char_err) + goto 9999 + else + vout(:,:) = vin(:,:) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + end subroutine psb_cpy_z_rk2 + + + function psb_size_z_rk1(vin) result(val) + integer(psb_epk_) :: val + complex(psb_dpk_), allocatable, intent(in) :: vin(:) + + if (.not.allocated(vin)) then + val = 0 + else + val = size(vin) + end if + end function psb_size_z_rk1 + + + function psb_size_z_rk2(vin,dim) result(val) + integer(psb_epk_) :: val + complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) + integer(psb_ipk_), optional :: dim + integer(psb_ipk_) :: dim_ + + + if (.not.allocated(vin)) then + val = 0 + else + if (present(dim)) then + dim_= dim + val = size(vin,dim=dim_) + else + val = size(vin) + end if + end if + end function psb_size_z_rk2 + + Subroutine psb_ensure_m_sz_z_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_mpk_),Intent(in) :: len + complex(psb_dpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_mpk_), optional, intent(in) :: addsz,newsz + complex(psb_dpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_mpk_) :: isz + + name='psb_ensure_m_sz_z_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_m_sz_z_rk1 + + Subroutine psb_ensure_e_sz_z_rk1(len,v,info,pad,addsz,newsz) + use psb_error_mod + + ! ...Subroutine Arguments + integer(psb_epk_),Intent(in) :: len + complex(psb_dpk_),allocatable, intent(inout) :: v(:) + integer(psb_ipk_) :: info + integer(psb_epk_), optional, intent(in) :: addsz,newsz + complex(psb_dpk_), optional, intent(in) :: pad + ! ...Local Variables + character(len=20) :: name + logical, parameter :: debug=.false. + integer(psb_ipk_) :: err_act + integer(psb_epk_) :: isz + + name='psb_ensure_m_sz_z_rk1' + call psb_erractionsave(err_act) + info = psb_success_ + + if (psb_errstatus_fatal()) then + info=psb_err_from_subroutine_ + goto 9999 + end if + + If (len > psb_size(v)) Then + if (present(newsz)) then + isz = (max(len+1,newsz)) + else + if (present(addsz)) then + isz = len+max(1,addsz) + else + isz = max(len+10, int(1.25*len)) + endif + endif + + call psb_realloc(isz,v,info,pad=pad) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + End If + end If + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + + End Subroutine psb_ensure_e_sz_z_rk1 + + Subroutine psb_move_alloc_z_rk1(vin,vout,info) + use psb_error_mod + complex(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_z_rk1 + + Subroutine psb_move_alloc_z_rk2(vin,vout,info) + use psb_error_mod + complex(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) + integer(psb_ipk_), intent(out) :: info + ! + ! + info=psb_success_ + + call move_alloc(vin,vout) + + end Subroutine psb_move_alloc_z_rk2 + +end module psb_z_realloc_mod diff --git a/base/modules/aux/psb_z_sort_mod.f90 b/base/modules/auxil/psb_z_sort_mod.f90 similarity index 99% rename from base/modules/aux/psb_z_sort_mod.f90 rename to base/modules/auxil/psb_z_sort_mod.f90 index 18d50a71a..0a408caf0 100644 --- a/base/modules/aux/psb_z_sort_mod.f90 +++ b/base/modules/auxil/psb_z_sort_mod.f90 @@ -44,6 +44,8 @@ module psb_z_sort_mod use psb_const_mod + @INTE@ + interface psb_msort_unique subroutine psb_zmsort_u(x,nout,dir) import @@ -553,7 +555,8 @@ contains implicit none class(psb_z_idx_heap), intent(inout) :: heap - integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(out) :: index + integer(psb_ipk_), intent(out) :: info complex(psb_dpk_), intent(out) :: key diff --git a/base/modules/aux/psi_c_serial_mod.f90 b/base/modules/auxil/psi_c_serial_mod.f90 similarity index 98% rename from base/modules/aux/psi_c_serial_mod.f90 rename to base/modules/auxil/psi_c_serial_mod.f90 index 894d9cc1c..5dc25dc44 100644 --- a/base/modules/aux/psi_c_serial_mod.f90 +++ b/base/modules/auxil/psi_c_serial_mod.f90 @@ -30,7 +30,7 @@ ! ! module psi_c_serial_mod - use psb_const_mod, only : psb_ipk_, psb_spk_ + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_spk_ interface psb_gelp ! 2-D version diff --git a/base/modules/aux/psi_d_serial_mod.f90 b/base/modules/auxil/psi_d_serial_mod.f90 similarity index 98% rename from base/modules/aux/psi_d_serial_mod.f90 rename to base/modules/auxil/psi_d_serial_mod.f90 index d2cba11bd..541446c70 100644 --- a/base/modules/aux/psi_d_serial_mod.f90 +++ b/base/modules/auxil/psi_d_serial_mod.f90 @@ -30,7 +30,7 @@ ! ! module psi_d_serial_mod - use psb_const_mod, only : psb_ipk_, psb_dpk_ + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_dpk_ interface psb_gelp ! 2-D version diff --git a/base/modules/aux/psi_i_serial_mod.f90 b/base/modules/auxil/psi_e_serial_mod.f90 similarity index 55% rename from base/modules/aux/psi_i_serial_mod.f90 rename to base/modules/auxil/psi_e_serial_mod.f90 index 894dcba9c..f95d812b4 100644 --- a/base/modules/aux/psi_i_serial_mod.f90 +++ b/base/modules/auxil/psi_e_serial_mod.f90 @@ -29,105 +29,105 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -module psi_i_serial_mod - use psb_const_mod, only : psb_ipk_ +module psi_e_serial_mod + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ interface psb_gelp ! 2-D version - subroutine psb_igelp(trans,iperm,x,info) - import :: psb_ipk_ + subroutine psb_egelp(trans,iperm,x,info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none - integer(psb_ipk_), intent(inout) :: x(:,:) + integer(psb_epk_), intent(inout) :: x(:,:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans - end subroutine psb_igelp - subroutine psb_igelpv(trans,iperm,x,info) - import :: psb_ipk_ + end subroutine psb_egelp + subroutine psb_egelpv(trans,iperm,x,info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none - integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: x(:) integer(psb_ipk_), intent(in) :: iperm(:) integer(psb_ipk_), intent(out) :: info character, intent(in) :: trans - end subroutine psb_igelpv + end subroutine psb_egelpv end interface psb_gelp interface psb_geaxpby - subroutine psi_iaxpby(m,n,alpha, x, beta, y, info) - import :: psb_ipk_ + subroutine psi_eaxpby(m,n,alpha, x, beta, y, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_), intent(in) :: m, n - integer(psb_ipk_), intent (in) :: x(:,:) - integer(psb_ipk_), intent (inout) :: y(:,:) - integer(psb_ipk_), intent (in) :: alpha, beta + integer(psb_epk_), intent (in) :: x(:,:) + integer(psb_epk_), intent (inout) :: y(:,:) + integer(psb_epk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - end subroutine psi_iaxpby - subroutine psi_iaxpbyv(m,alpha, x, beta, y, info) - import :: psb_ipk_ + end subroutine psi_eaxpby + subroutine psi_eaxpbyv(m,alpha, x, beta, y, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent (in) :: x(:) - integer(psb_ipk_), intent (inout) :: y(:) - integer(psb_ipk_), intent (in) :: alpha, beta + integer(psb_epk_), intent (in) :: x(:) + integer(psb_epk_), intent (inout) :: y(:) + integer(psb_epk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info - end subroutine psi_iaxpbyv + end subroutine psi_eaxpbyv end interface psb_geaxpby interface psi_gth - subroutine psi_igthmv(n,k,idx,alpha,x,beta,y) - import :: psb_ipk_ + subroutine psi_egthmv(n,k,idx,alpha,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: x(:,:), y(:),alpha,beta - end subroutine psi_igthmv - subroutine psi_igthv(n,idx,alpha,x,beta,y) - import :: psb_ipk_ + integer(psb_epk_) :: x(:,:), y(:),alpha,beta + end subroutine psi_egthmv + subroutine psi_egthv(n,idx,alpha,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, idx(:) - integer(psb_ipk_) :: x(:), y(:),alpha,beta - end subroutine psi_igthv - subroutine psi_igthzmv(n,k,idx,x,y) - import :: psb_ipk_ + integer(psb_epk_) :: x(:), y(:),alpha,beta + end subroutine psi_egthv + subroutine psi_egthzmv(n,k,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: x(:,:), y(:) + integer(psb_epk_) :: x(:,:), y(:) - end subroutine psi_igthzmv - subroutine psi_igthzmm(n,k,idx,x,y) - import :: psb_ipk_ + end subroutine psi_egthzmv + subroutine psi_egthzmm(n,k,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: x(:,:), y(:,:) + integer(psb_epk_) :: x(:,:), y(:,:) - end subroutine psi_igthzmm - subroutine psi_igthzv(n,idx,x,y) - import :: psb_ipk_ + end subroutine psi_egthzmm + subroutine psi_egthzv(n,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, idx(:) - integer(psb_ipk_) :: x(:), y(:) - end subroutine psi_igthzv + integer(psb_epk_) :: x(:), y(:) + end subroutine psi_egthzv end interface psi_gth interface psi_sct - subroutine psi_isctmm(n,k,idx,x,beta,y) - import :: psb_ipk_ + subroutine psi_esctmm(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: beta, x(:,:), y(:,:) - end subroutine psi_isctmm - subroutine psi_isctmv(n,k,idx,x,beta,y) - import :: psb_ipk_ + integer(psb_epk_) :: beta, x(:,:), y(:,:) + end subroutine psi_esctmm + subroutine psi_esctmv(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: beta, x(:), y(:,:) - end subroutine psi_isctmv - subroutine psi_isctv(n,idx,x,beta,y) - import :: psb_ipk_ + integer(psb_epk_) :: beta, x(:), y(:,:) + end subroutine psi_esctmv + subroutine psi_esctv(n,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ implicit none integer(psb_ipk_) :: n, idx(:) - integer(psb_ipk_) :: beta, x(:), y(:) - end subroutine psi_isctv + integer(psb_epk_) :: beta, x(:), y(:) + end subroutine psi_esctv end interface psi_sct -end module psi_i_serial_mod +end module psi_e_serial_mod diff --git a/base/modules/auxil/psi_m_serial_mod.f90 b/base/modules/auxil/psi_m_serial_mod.f90 new file mode 100644 index 000000000..e9575fc7b --- /dev/null +++ b/base/modules/auxil/psi_m_serial_mod.f90 @@ -0,0 +1,133 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_m_serial_mod + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_gelp + ! 2-D version + subroutine psb_mgelp(trans,iperm,x,info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_ipk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + end subroutine psb_mgelp + subroutine psb_mgelpv(trans,iperm,x,info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in) :: trans + end subroutine psb_mgelpv + end interface psb_gelp + + interface psb_geaxpby + subroutine psi_maxpby(m,n,alpha, x, beta, y, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: m, n + integer(psb_mpk_), intent (in) :: x(:,:) + integer(psb_mpk_), intent (inout) :: y(:,:) + integer(psb_mpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_maxpby + subroutine psi_maxpbyv(m,alpha, x, beta, y, info) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_mpk_), intent (in) :: x(:) + integer(psb_mpk_), intent (inout) :: y(:) + integer(psb_mpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + end subroutine psi_maxpbyv + end interface psb_geaxpby + + interface psi_gth + subroutine psi_mgthmv(n,k,idx,alpha,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: x(:,:), y(:),alpha,beta + end subroutine psi_mgthmv + subroutine psi_mgthv(n,idx,alpha,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_mpk_) :: x(:), y(:),alpha,beta + end subroutine psi_mgthv + subroutine psi_mgthzmv(n,k,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: x(:,:), y(:) + + end subroutine psi_mgthzmv + subroutine psi_mgthzmm(n,k,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: x(:,:), y(:,:) + + end subroutine psi_mgthzmm + subroutine psi_mgthzv(n,idx,x,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_mpk_) :: x(:), y(:) + end subroutine psi_mgthzv + end interface psi_gth + + interface psi_sct + subroutine psi_msctmm(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: beta, x(:,:), y(:,:) + end subroutine psi_msctmm + subroutine psi_msctmv(n,k,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: beta, x(:), y(:,:) + end subroutine psi_msctmv + subroutine psi_msctv(n,idx,x,beta,y) + import :: psb_ipk_, psb_lpk_,psb_mpk_, psb_epk_ + implicit none + + integer(psb_ipk_) :: n, idx(:) + integer(psb_mpk_) :: beta, x(:), y(:) + end subroutine psi_msctv + end interface psi_sct + +end module psi_m_serial_mod diff --git a/base/modules/aux/psi_s_serial_mod.f90 b/base/modules/auxil/psi_s_serial_mod.f90 similarity index 98% rename from base/modules/aux/psi_s_serial_mod.f90 rename to base/modules/auxil/psi_s_serial_mod.f90 index a547dc0c0..443b16fe8 100644 --- a/base/modules/aux/psi_s_serial_mod.f90 +++ b/base/modules/auxil/psi_s_serial_mod.f90 @@ -30,7 +30,7 @@ ! ! module psi_s_serial_mod - use psb_const_mod, only : psb_ipk_, psb_spk_ + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_spk_ interface psb_gelp ! 2-D version diff --git a/base/modules/aux/psi_serial_mod.f90 b/base/modules/auxil/psi_serial_mod.f90 similarity index 97% rename from base/modules/aux/psi_serial_mod.f90 rename to base/modules/auxil/psi_serial_mod.f90 index 9125fed82..249ecaa2b 100644 --- a/base/modules/aux/psi_serial_mod.f90 +++ b/base/modules/auxil/psi_serial_mod.f90 @@ -30,7 +30,8 @@ ! ! module psi_serial_mod - use psi_i_serial_mod + use psi_m_serial_mod + use psi_e_serial_mod use psi_s_serial_mod use psi_d_serial_mod use psi_c_serial_mod diff --git a/base/modules/aux/psi_z_serial_mod.f90 b/base/modules/auxil/psi_z_serial_mod.f90 similarity index 98% rename from base/modules/aux/psi_z_serial_mod.f90 rename to base/modules/auxil/psi_z_serial_mod.f90 index 309b09ef0..f0d7dd115 100644 --- a/base/modules/aux/psi_z_serial_mod.f90 +++ b/base/modules/auxil/psi_z_serial_mod.f90 @@ -30,7 +30,7 @@ ! ! module psi_z_serial_mod - use psb_const_mod, only : psb_ipk_, psb_dpk_ + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, psb_dpk_ interface psb_gelp ! 2-D version diff --git a/base/modules/comm/psb_base_linmap_mod.f90 b/base/modules/comm/psb_base_linmap_mod.f90 index 760ec3ce6..3dccac3f2 100644 --- a/base/modules/comm/psb_base_linmap_mod.f90 +++ b/base/modules/comm/psb_base_linmap_mod.f90 @@ -42,7 +42,7 @@ module psb_base_linmap_mod type psb_base_linmap_type integer(psb_ipk_) :: kind - integer(psb_ipk_), allocatable :: iaggr(:), naggr(:) + integer(psb_lpk_), allocatable :: iaggr(:), naggr(:) type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null() type(psb_desc_type) :: desc_X, desc_Y contains @@ -124,13 +124,13 @@ contains use psb_desc_mod implicit none class(psb_base_linmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val - val = psb_sizeof_int + val = psb_sizeof_ip if (allocated(map%iaggr)) & - & val = val + psb_sizeof_int*size(map%iaggr) + & val = val + psb_sizeof_lp*size(map%iaggr) if (allocated(map%naggr)) & - & val = val + psb_sizeof_int*size(map%naggr) + & val = val + psb_sizeof_lp*size(map%naggr) val = val + map%desc_X%sizeof() val = val + map%desc_Y%sizeof() diff --git a/base/modules/comm/psb_c_comm_a_mod.f90 b/base/modules/comm/psb_c_comm_a_mod.f90 new file mode 100644 index 000000000..5d0b236ef --- /dev/null +++ b/base/modules/comm/psb_c_comm_a_mod.f90 @@ -0,0 +1,122 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_c_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_ + + interface psb_ovrl + subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) + import + implicit none + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + end subroutine psb_covrlm + subroutine psb_covrlv(x,desc_a,info,work,update,mode) + import + implicit none + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_covrlv + end interface psb_ovrl + + interface psb_halo + subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) + import + implicit none + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_chalom + subroutine psb_chalov(x,desc_a,info,work,tran,mode,data) + import + implicit none + complex(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_chalov + end interface psb_halo + + + interface psb_scatter + subroutine psb_cscatterm(globx, locx, desc_a, info, root) + import + implicit none + complex(psb_spk_), intent(out), allocatable :: locx(:,:) + complex(psb_spk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_cscatterm + subroutine psb_cscatterv(globx, locx, desc_a, info, root) + import + implicit none + complex(psb_spk_), intent(out), allocatable :: locx(:) + complex(psb_spk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_cscatterv + end interface psb_scatter + + interface psb_gather + subroutine psb_cgatherm(globx, locx, desc_a, info, root) + import + implicit none + complex(psb_spk_), intent(in) :: locx(:,:) + complex(psb_spk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_cgatherm + subroutine psb_cgatherv(globx, locx, desc_a, info, root) + import + implicit none + complex(psb_spk_), intent(in) :: locx(:) + complex(psb_spk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_cgatherv + end interface psb_gather + +end module psb_c_comm_a_mod diff --git a/base/modules/comm/psb_c_comm_mod.f90 b/base/modules/comm/psb_c_comm_mod.f90 index e14d6673c..c2a855102 100644 --- a/base/modules/comm/psb_c_comm_mod.f90 +++ b/base/modules/comm/psb_c_comm_mod.f90 @@ -31,30 +31,12 @@ ! module psb_c_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_ - use psb_mat_mod, only : psb_cspmat_type + use psb_mat_mod, only : psb_cspmat_type, psb_lcspmat_type use psb_c_vect_mod, only : psb_c_vect_type, psb_c_base_vect_type use psb_c_multivect_mod, only : psb_c_multivect_type, psb_c_base_multivect_type interface psb_ovrl - subroutine psb_covrlm(x,desc_a,info,jx,ik,work,update,mode) - import - implicit none - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - end subroutine psb_covrlm - subroutine psb_covrlv(x,desc_a,info,work,update,mode) - import - implicit none - complex(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - end subroutine psb_covrlv subroutine psb_covrl_vect(x,desc_a,info,work,update,mode) import implicit none @@ -76,26 +58,6 @@ module psb_c_comm_mod end interface psb_ovrl interface psb_halo - subroutine psb_chalom(x,desc_a,info,jx,ik,work,tran,mode,data) - import - implicit none - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_chalom - subroutine psb_chalov(x,desc_a,info,work,tran,mode,data) - import - implicit none - complex(psb_spk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_chalov subroutine psb_chalo_vect(x,desc_a,info,work,tran,mode,data) import implicit none @@ -120,24 +82,6 @@ module psb_c_comm_mod interface psb_scatter - subroutine psb_cscatterm(globx, locx, desc_a, info, root) - import - implicit none - complex(psb_spk_), intent(out), allocatable :: locx(:,:) - complex(psb_spk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_cscatterm - subroutine psb_cscatterv(globx, locx, desc_a, info, root) - import - implicit none - complex(psb_spk_), intent(out), allocatable :: locx(:) - complex(psb_spk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_cscatterv subroutine psb_cscatter_vect(globx, locx, desc_a, info, root, mold) import implicit none @@ -161,24 +105,26 @@ module psb_c_comm_mod integer(psb_ipk_), intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_csp_allgather - subroutine psb_cgatherm(globx, locx, desc_a, info, root) + subroutine psb_lcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) import implicit none - complex(psb_spk_), intent(in) :: locx(:,:) - complex(psb_spk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_cgatherm - subroutine psb_cgatherv(globx, locx, desc_a, info, root) + type(psb_cspmat_type), intent(inout) :: loca + type(psb_lcspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lcsp_allgather + subroutine psb_lclcsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) import implicit none - complex(psb_spk_), intent(in) :: locx(:) - complex(psb_spk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_cgatherv + type(psb_lcspmat_type), intent(inout) :: loca + type(psb_lcspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lclcsp_allgather subroutine psb_cgather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/comm/psb_c_linmap_mod.f90 b/base/modules/comm/psb_c_linmap_mod.f90 index 90301141d..42dd05e73 100644 --- a/base/modules/comm/psb_c_linmap_mod.f90 +++ b/base/modules/comm/psb_c_linmap_mod.f90 @@ -38,8 +38,8 @@ module psb_c_linmap_mod use psb_const_mod - use psb_c_mat_mod, only : psb_cspmat_type - use psb_desc_mod, only : psb_desc_type + use psb_c_mat_mod + use psb_desc_mod use psb_base_linmap_mod @@ -118,13 +118,13 @@ module psb_c_linmap_mod interface psb_linmap function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) use psb_c_mat_mod, only : psb_cspmat_type - import :: psb_ipk_, psb_clinmap_type, psb_desc_type + import :: psb_ipk_, psb_clinmap_type, psb_desc_type, psb_lpk_ implicit none type(psb_clinmap_type) :: psb_c_linmap type(psb_desc_type), target :: desc_X, desc_Y type(psb_cspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) end function psb_c_linmap end interface @@ -137,11 +137,9 @@ module psb_c_linmap_mod contains function c_map_sizeof(map) result(val) - use psb_desc_mod - use psb_c_mat_mod implicit none class(psb_clinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = map%psb_base_linmap_type%sizeof() val = val + map%map_X2Y%sizeof() @@ -151,7 +149,6 @@ contains function c_is_asb(map) result(val) - use psb_desc_mod implicit none class(psb_clinmap_type), intent(in) :: map logical :: val @@ -163,8 +160,6 @@ contains subroutine psb_c_map_cscnv(map,info,type,mold,imold) - use psb_i_vect_mod - use psb_c_mat_mod implicit none class(psb_clinmap_type), intent(inout) :: map integer(psb_ipk_), intent(out) :: info @@ -185,20 +180,17 @@ contains subroutine psb_c_linmap_sub(out_map,map_kind,desc_X, desc_Y,& & map_X2Y, map_Y2X,iaggr,naggr) - use psb_c_mat_mod implicit none type(psb_clinmap_type), intent(out) :: out_map type(psb_desc_type), target :: desc_X, desc_Y type(psb_cspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr) end subroutine psb_c_linmap_sub subroutine psb_clinmap_transfer(mapin,mapout,info) use psb_realloc_mod - use psb_desc_mod - use psb_mat_mod, only : psb_move_alloc implicit none type(psb_clinmap_type) :: mapin,mapout integer(psb_ipk_), intent(out) :: info @@ -211,7 +203,6 @@ contains end subroutine psb_clinmap_transfer subroutine c_free(map,info) - use psb_desc_mod implicit none class(psb_clinmap_type) :: map integer(psb_ipk_), intent(out) :: info @@ -225,7 +216,6 @@ contains subroutine c_clone(map,mapout,info) - use psb_desc_mod use psb_error_mod implicit none class(psb_clinmap_type), intent(inout) :: map @@ -233,7 +223,6 @@ contains integer(psb_ipk_) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='clone' info = 0 @@ -247,9 +236,8 @@ contains if (info == 0) call map%map_Y2X%clone(mout%map_Y2X,info) class default info = psb_err_invalid_dynamic_type_ - ierr(1) = 2 info = psb_err_missing_override_method_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/2/)) call psb_erractionsave(err_act) call psb_error_handler(err_act) diff --git a/base/modules/comm/psb_comm_mod.f90 b/base/modules/comm/psb_comm_mod.f90 index bd2b1f3d4..17cffe4cd 100644 --- a/base/modules/comm/psb_comm_mod.f90 +++ b/base/modules/comm/psb_comm_mod.f90 @@ -31,7 +31,15 @@ ! module psb_comm_mod + use psb_m_comm_a_mod + use psb_e_comm_a_mod + use psb_s_comm_a_mod + use psb_d_comm_a_mod + use psb_c_comm_a_mod + use psb_z_comm_a_mod + use psb_i_comm_mod + use psb_l_comm_mod use psb_s_comm_mod use psb_d_comm_mod use psb_c_comm_mod diff --git a/base/modules/comm/psb_d_comm_a_mod.f90 b/base/modules/comm/psb_d_comm_a_mod.f90 new file mode 100644 index 000000000..8053f2d5e --- /dev/null +++ b/base/modules/comm/psb_d_comm_a_mod.f90 @@ -0,0 +1,122 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_d_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_ + + interface psb_ovrl + subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) + import + implicit none + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + end subroutine psb_dovrlm + subroutine psb_dovrlv(x,desc_a,info,work,update,mode) + import + implicit none + real(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_dovrlv + end interface psb_ovrl + + interface psb_halo + subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) + import + implicit none + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_dhalom + subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) + import + implicit none + real(psb_dpk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_dhalov + end interface psb_halo + + + interface psb_scatter + subroutine psb_dscatterm(globx, locx, desc_a, info, root) + import + implicit none + real(psb_dpk_), intent(out), allocatable :: locx(:,:) + real(psb_dpk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_dscatterm + subroutine psb_dscatterv(globx, locx, desc_a, info, root) + import + implicit none + real(psb_dpk_), intent(out), allocatable :: locx(:) + real(psb_dpk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_dscatterv + end interface psb_scatter + + interface psb_gather + subroutine psb_dgatherm(globx, locx, desc_a, info, root) + import + implicit none + real(psb_dpk_), intent(in) :: locx(:,:) + real(psb_dpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_dgatherm + subroutine psb_dgatherv(globx, locx, desc_a, info, root) + import + implicit none + real(psb_dpk_), intent(in) :: locx(:) + real(psb_dpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_dgatherv + end interface psb_gather + +end module psb_d_comm_a_mod diff --git a/base/modules/comm/psb_d_comm_mod.f90 b/base/modules/comm/psb_d_comm_mod.f90 index 7c532dadc..5efde2b0c 100644 --- a/base/modules/comm/psb_d_comm_mod.f90 +++ b/base/modules/comm/psb_d_comm_mod.f90 @@ -31,30 +31,12 @@ ! module psb_d_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_ - use psb_mat_mod, only : psb_dspmat_type + use psb_mat_mod, only : psb_dspmat_type, psb_ldspmat_type use psb_d_vect_mod, only : psb_d_vect_type, psb_d_base_vect_type use psb_d_multivect_mod, only : psb_d_multivect_type, psb_d_base_multivect_type interface psb_ovrl - subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update,mode) - import - implicit none - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - end subroutine psb_dovrlm - subroutine psb_dovrlv(x,desc_a,info,work,update,mode) - import - implicit none - real(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - end subroutine psb_dovrlv subroutine psb_dovrl_vect(x,desc_a,info,work,update,mode) import implicit none @@ -76,26 +58,6 @@ module psb_d_comm_mod end interface psb_ovrl interface psb_halo - subroutine psb_dhalom(x,desc_a,info,jx,ik,work,tran,mode,data) - import - implicit none - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_dhalom - subroutine psb_dhalov(x,desc_a,info,work,tran,mode,data) - import - implicit none - real(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_dhalov subroutine psb_dhalo_vect(x,desc_a,info,work,tran,mode,data) import implicit none @@ -120,24 +82,6 @@ module psb_d_comm_mod interface psb_scatter - subroutine psb_dscatterm(globx, locx, desc_a, info, root) - import - implicit none - real(psb_dpk_), intent(out), allocatable :: locx(:,:) - real(psb_dpk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_dscatterm - subroutine psb_dscatterv(globx, locx, desc_a, info, root) - import - implicit none - real(psb_dpk_), intent(out), allocatable :: locx(:) - real(psb_dpk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_dscatterv subroutine psb_dscatter_vect(globx, locx, desc_a, info, root, mold) import implicit none @@ -161,24 +105,26 @@ module psb_d_comm_mod integer(psb_ipk_), intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_dsp_allgather - subroutine psb_dgatherm(globx, locx, desc_a, info, root) + subroutine psb_ldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) import implicit none - real(psb_dpk_), intent(in) :: locx(:,:) - real(psb_dpk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_dgatherm - subroutine psb_dgatherv(globx, locx, desc_a, info, root) + type(psb_dspmat_type), intent(inout) :: loca + type(psb_ldspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_ldsp_allgather + subroutine psb_ldldsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) import implicit none - real(psb_dpk_), intent(in) :: locx(:) - real(psb_dpk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_dgatherv + type(psb_ldspmat_type), intent(inout) :: loca + type(psb_ldspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_ldldsp_allgather subroutine psb_dgather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/comm/psb_d_linmap_mod.f90 b/base/modules/comm/psb_d_linmap_mod.f90 index 9fd661d8a..80d27e262 100644 --- a/base/modules/comm/psb_d_linmap_mod.f90 +++ b/base/modules/comm/psb_d_linmap_mod.f90 @@ -38,8 +38,8 @@ module psb_d_linmap_mod use psb_const_mod - use psb_d_mat_mod, only : psb_dspmat_type - use psb_desc_mod, only : psb_desc_type + use psb_d_mat_mod + use psb_desc_mod use psb_base_linmap_mod @@ -118,13 +118,13 @@ module psb_d_linmap_mod interface psb_linmap function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) use psb_d_mat_mod, only : psb_dspmat_type - import :: psb_ipk_, psb_dlinmap_type, psb_desc_type + import :: psb_ipk_, psb_dlinmap_type, psb_desc_type, psb_lpk_ implicit none type(psb_dlinmap_type) :: psb_d_linmap type(psb_desc_type), target :: desc_X, desc_Y type(psb_dspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) end function psb_d_linmap end interface @@ -137,11 +137,9 @@ module psb_d_linmap_mod contains function d_map_sizeof(map) result(val) - use psb_desc_mod - use psb_d_mat_mod implicit none class(psb_dlinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = map%psb_base_linmap_type%sizeof() val = val + map%map_X2Y%sizeof() @@ -151,7 +149,6 @@ contains function d_is_asb(map) result(val) - use psb_desc_mod implicit none class(psb_dlinmap_type), intent(in) :: map logical :: val @@ -163,8 +160,6 @@ contains subroutine psb_d_map_cscnv(map,info,type,mold,imold) - use psb_i_vect_mod - use psb_d_mat_mod implicit none class(psb_dlinmap_type), intent(inout) :: map integer(psb_ipk_), intent(out) :: info @@ -185,20 +180,17 @@ contains subroutine psb_d_linmap_sub(out_map,map_kind,desc_X, desc_Y,& & map_X2Y, map_Y2X,iaggr,naggr) - use psb_d_mat_mod implicit none type(psb_dlinmap_type), intent(out) :: out_map type(psb_desc_type), target :: desc_X, desc_Y type(psb_dspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr) end subroutine psb_d_linmap_sub subroutine psb_dlinmap_transfer(mapin,mapout,info) use psb_realloc_mod - use psb_desc_mod - use psb_mat_mod, only : psb_move_alloc implicit none type(psb_dlinmap_type) :: mapin,mapout integer(psb_ipk_), intent(out) :: info @@ -211,7 +203,6 @@ contains end subroutine psb_dlinmap_transfer subroutine d_free(map,info) - use psb_desc_mod implicit none class(psb_dlinmap_type) :: map integer(psb_ipk_), intent(out) :: info @@ -225,7 +216,6 @@ contains subroutine d_clone(map,mapout,info) - use psb_desc_mod use psb_error_mod implicit none class(psb_dlinmap_type), intent(inout) :: map @@ -233,7 +223,6 @@ contains integer(psb_ipk_) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='clone' info = 0 @@ -247,9 +236,8 @@ contains if (info == 0) call map%map_Y2X%clone(mout%map_Y2X,info) class default info = psb_err_invalid_dynamic_type_ - ierr(1) = 2 info = psb_err_missing_override_method_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/2/)) call psb_erractionsave(err_act) call psb_error_handler(err_act) diff --git a/base/modules/comm/psb_e_comm_a_mod.f90 b/base/modules/comm/psb_e_comm_a_mod.f90 new file mode 100644 index 000000000..19f1cb012 --- /dev/null +++ b/base/modules/comm/psb_e_comm_a_mod.f90 @@ -0,0 +1,122 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_e_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_ + + interface psb_ovrl + subroutine psb_eovrlm(x,desc_a,info,jx,ik,work,update,mode) + import + implicit none + integer(psb_epk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + end subroutine psb_eovrlm + subroutine psb_eovrlv(x,desc_a,info,work,update,mode) + import + implicit none + integer(psb_epk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_eovrlv + end interface psb_ovrl + + interface psb_halo + subroutine psb_ehalom(x,desc_a,info,jx,ik,work,tran,mode,data) + import + implicit none + integer(psb_epk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_ehalom + subroutine psb_ehalov(x,desc_a,info,work,tran,mode,data) + import + implicit none + integer(psb_epk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_ehalov + end interface psb_halo + + + interface psb_scatter + subroutine psb_escatterm(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_epk_), intent(out), allocatable :: locx(:,:) + integer(psb_epk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_escatterm + subroutine psb_escatterv(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_epk_), intent(out), allocatable :: locx(:) + integer(psb_epk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_escatterv + end interface psb_scatter + + interface psb_gather + subroutine psb_egatherm(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_epk_), intent(in) :: locx(:,:) + integer(psb_epk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_egatherm + subroutine psb_egatherv(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_epk_), intent(in) :: locx(:) + integer(psb_epk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_egatherv + end interface psb_gather + +end module psb_e_comm_a_mod diff --git a/base/modules/comm/psb_i_comm_mod.f90 b/base/modules/comm/psb_i_comm_mod.f90 index fe2a72910..b727f4035 100644 --- a/base/modules/comm/psb_i_comm_mod.f90 +++ b/base/modules/comm/psb_i_comm_mod.f90 @@ -30,30 +30,12 @@ ! ! module psb_i_comm_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_ use psb_i_vect_mod, only : psb_i_vect_type, psb_i_base_vect_type use psb_i_multivect_mod, only : psb_i_multivect_type, psb_i_base_multivect_type interface psb_ovrl - subroutine psb_iovrlm(x,desc_a,info,jx,ik,work,update,mode) - import - implicit none - integer(psb_ipk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - end subroutine psb_iovrlm - subroutine psb_iovrlv(x,desc_a,info,work,update,mode) - import - implicit none - integer(psb_ipk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - end subroutine psb_iovrlv subroutine psb_iovrl_vect(x,desc_a,info,work,update,mode) import implicit none @@ -75,26 +57,6 @@ module psb_i_comm_mod end interface psb_ovrl interface psb_halo - subroutine psb_ihalom(x,desc_a,info,jx,ik,work,tran,mode,data) - import - implicit none - integer(psb_ipk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_ihalom - subroutine psb_ihalov(x,desc_a,info,work,tran,mode,data) - import - implicit none - integer(psb_ipk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_ihalov subroutine psb_ihalo_vect(x,desc_a,info,work,tran,mode,data) import implicit none @@ -119,24 +81,6 @@ module psb_i_comm_mod interface psb_scatter - subroutine psb_iscatterm(globx, locx, desc_a, info, root) - import - implicit none - integer(psb_ipk_), intent(out), allocatable :: locx(:,:) - integer(psb_ipk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_iscatterm - subroutine psb_iscatterv(globx, locx, desc_a, info, root) - import - implicit none - integer(psb_ipk_), intent(out), allocatable :: locx(:) - integer(psb_ipk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_iscatterv subroutine psb_iscatter_vect(globx, locx, desc_a, info, root, mold) import implicit none @@ -150,24 +94,6 @@ module psb_i_comm_mod end interface psb_scatter interface psb_gather - subroutine psb_igatherm(globx, locx, desc_a, info, root) - import - implicit none - integer(psb_ipk_), intent(in) :: locx(:,:) - integer(psb_ipk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_igatherm - subroutine psb_igatherv(globx, locx, desc_a, info, root) - import - implicit none - integer(psb_ipk_), intent(in) :: locx(:) - integer(psb_ipk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_igatherv subroutine psb_igather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/comm/psb_l_comm_mod.f90 b/base/modules/comm/psb_l_comm_mod.f90 new file mode 100644 index 000000000..1072b824c --- /dev/null +++ b/base/modules/comm/psb_l_comm_mod.f90 @@ -0,0 +1,117 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_l_comm_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_ + + use psb_l_vect_mod, only : psb_l_vect_type, psb_l_base_vect_type + use psb_l_multivect_mod, only : psb_l_multivect_type, psb_l_base_multivect_type + + interface psb_ovrl + subroutine psb_lovrl_vect(x,desc_a,info,work,update,mode) + import + implicit none + type(psb_l_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_lovrl_vect + subroutine psb_lovrl_multivect(x,desc_a,info,work,update,mode) + import + implicit none + type(psb_l_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_lovrl_multivect + end interface psb_ovrl + + interface psb_halo + subroutine psb_lhalo_vect(x,desc_a,info,work,tran,mode,data) + import + implicit none + type(psb_l_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_lhalo_vect + subroutine psb_lhalo_multivect(x,desc_a,info,work,tran,mode,data) + import + implicit none + type(psb_l_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_lhalo_multivect + end interface psb_halo + + + interface psb_scatter + subroutine psb_lscatter_vect(globx, locx, desc_a, info, root, mold) + import + implicit none + type(psb_l_vect_type), intent(inout) :: locx + integer(psb_lpk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + class(psb_l_base_vect_type), intent(in), optional :: mold + end subroutine psb_lscatter_vect + end interface psb_scatter + + interface psb_gather + subroutine psb_lgather_vect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_l_vect_type), intent(inout) :: locx + integer(psb_lpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_lgather_vect + subroutine psb_lgather_multivect(globx, locx, desc_a, info, root) + import + implicit none + type(psb_l_multivect_type), intent(inout) :: locx + integer(psb_lpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_lgather_multivect + end interface psb_gather + +end module psb_l_comm_mod diff --git a/base/modules/comm/psb_m_comm_a_mod.f90 b/base/modules/comm/psb_m_comm_a_mod.f90 new file mode 100644 index 000000000..91124a534 --- /dev/null +++ b/base/modules/comm/psb_m_comm_a_mod.f90 @@ -0,0 +1,122 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_m_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_epk_, psb_mpk_ + + interface psb_ovrl + subroutine psb_movrlm(x,desc_a,info,jx,ik,work,update,mode) + import + implicit none + integer(psb_mpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + end subroutine psb_movrlm + subroutine psb_movrlv(x,desc_a,info,work,update,mode) + import + implicit none + integer(psb_mpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_movrlv + end interface psb_ovrl + + interface psb_halo + subroutine psb_mhalom(x,desc_a,info,jx,ik,work,tran,mode,data) + import + implicit none + integer(psb_mpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_mhalom + subroutine psb_mhalov(x,desc_a,info,work,tran,mode,data) + import + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_mhalov + end interface psb_halo + + + interface psb_scatter + subroutine psb_mscatterm(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_mpk_), intent(out), allocatable :: locx(:,:) + integer(psb_mpk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_mscatterm + subroutine psb_mscatterv(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_mpk_), intent(out), allocatable :: locx(:) + integer(psb_mpk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_mscatterv + end interface psb_scatter + + interface psb_gather + subroutine psb_mgatherm(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_mpk_), intent(in) :: locx(:,:) + integer(psb_mpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_mgatherm + subroutine psb_mgatherv(globx, locx, desc_a, info, root) + import + implicit none + integer(psb_mpk_), intent(in) :: locx(:) + integer(psb_mpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_mgatherv + end interface psb_gather + +end module psb_m_comm_a_mod diff --git a/base/modules/comm/psb_s_comm_a_mod.f90 b/base/modules/comm/psb_s_comm_a_mod.f90 new file mode 100644 index 000000000..9e7a768a2 --- /dev/null +++ b/base/modules/comm/psb_s_comm_a_mod.f90 @@ -0,0 +1,122 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_s_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_ + + interface psb_ovrl + subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) + import + implicit none + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + end subroutine psb_sovrlm + subroutine psb_sovrlv(x,desc_a,info,work,update,mode) + import + implicit none + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_sovrlv + end interface psb_ovrl + + interface psb_halo + subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data) + import + implicit none + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_shalom + subroutine psb_shalov(x,desc_a,info,work,tran,mode,data) + import + implicit none + real(psb_spk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_shalov + end interface psb_halo + + + interface psb_scatter + subroutine psb_sscatterm(globx, locx, desc_a, info, root) + import + implicit none + real(psb_spk_), intent(out), allocatable :: locx(:,:) + real(psb_spk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_sscatterm + subroutine psb_sscatterv(globx, locx, desc_a, info, root) + import + implicit none + real(psb_spk_), intent(out), allocatable :: locx(:) + real(psb_spk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_sscatterv + end interface psb_scatter + + interface psb_gather + subroutine psb_sgatherm(globx, locx, desc_a, info, root) + import + implicit none + real(psb_spk_), intent(in) :: locx(:,:) + real(psb_spk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_sgatherm + subroutine psb_sgatherv(globx, locx, desc_a, info, root) + import + implicit none + real(psb_spk_), intent(in) :: locx(:) + real(psb_spk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_sgatherv + end interface psb_gather + +end module psb_s_comm_a_mod diff --git a/base/modules/comm/psb_s_comm_mod.f90 b/base/modules/comm/psb_s_comm_mod.f90 index 82c848b73..a55e0c55e 100644 --- a/base/modules/comm/psb_s_comm_mod.f90 +++ b/base/modules/comm/psb_s_comm_mod.f90 @@ -31,30 +31,12 @@ ! module psb_s_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_ - use psb_mat_mod, only : psb_sspmat_type + use psb_mat_mod, only : psb_sspmat_type, psb_lsspmat_type use psb_s_vect_mod, only : psb_s_vect_type, psb_s_base_vect_type use psb_s_multivect_mod, only : psb_s_multivect_type, psb_s_base_multivect_type interface psb_ovrl - subroutine psb_sovrlm(x,desc_a,info,jx,ik,work,update,mode) - import - implicit none - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - end subroutine psb_sovrlm - subroutine psb_sovrlv(x,desc_a,info,work,update,mode) - import - implicit none - real(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - end subroutine psb_sovrlv subroutine psb_sovrl_vect(x,desc_a,info,work,update,mode) import implicit none @@ -76,26 +58,6 @@ module psb_s_comm_mod end interface psb_ovrl interface psb_halo - subroutine psb_shalom(x,desc_a,info,jx,ik,work,tran,mode,data) - import - implicit none - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_shalom - subroutine psb_shalov(x,desc_a,info,work,tran,mode,data) - import - implicit none - real(psb_spk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - real(psb_spk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_shalov subroutine psb_shalo_vect(x,desc_a,info,work,tran,mode,data) import implicit none @@ -120,24 +82,6 @@ module psb_s_comm_mod interface psb_scatter - subroutine psb_sscatterm(globx, locx, desc_a, info, root) - import - implicit none - real(psb_spk_), intent(out), allocatable :: locx(:,:) - real(psb_spk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_sscatterm - subroutine psb_sscatterv(globx, locx, desc_a, info, root) - import - implicit none - real(psb_spk_), intent(out), allocatable :: locx(:) - real(psb_spk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_sscatterv subroutine psb_sscatter_vect(globx, locx, desc_a, info, root, mold) import implicit none @@ -161,24 +105,26 @@ module psb_s_comm_mod integer(psb_ipk_), intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_ssp_allgather - subroutine psb_sgatherm(globx, locx, desc_a, info, root) + subroutine psb_lssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) import implicit none - real(psb_spk_), intent(in) :: locx(:,:) - real(psb_spk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_sgatherm - subroutine psb_sgatherv(globx, locx, desc_a, info, root) + type(psb_sspmat_type), intent(inout) :: loca + type(psb_lsspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lssp_allgather + subroutine psb_lslssp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) import implicit none - real(psb_spk_), intent(in) :: locx(:) - real(psb_spk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_sgatherv + type(psb_lsspmat_type), intent(inout) :: loca + type(psb_lsspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lslssp_allgather subroutine psb_sgather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/comm/psb_s_linmap_mod.f90 b/base/modules/comm/psb_s_linmap_mod.f90 index 5e44e2c9d..29f32c34f 100644 --- a/base/modules/comm/psb_s_linmap_mod.f90 +++ b/base/modules/comm/psb_s_linmap_mod.f90 @@ -38,8 +38,8 @@ module psb_s_linmap_mod use psb_const_mod - use psb_s_mat_mod, only : psb_sspmat_type - use psb_desc_mod, only : psb_desc_type + use psb_s_mat_mod + use psb_desc_mod use psb_base_linmap_mod @@ -118,13 +118,13 @@ module psb_s_linmap_mod interface psb_linmap function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) use psb_s_mat_mod, only : psb_sspmat_type - import :: psb_ipk_, psb_slinmap_type, psb_desc_type + import :: psb_ipk_, psb_slinmap_type, psb_desc_type, psb_lpk_ implicit none type(psb_slinmap_type) :: psb_s_linmap type(psb_desc_type), target :: desc_X, desc_Y type(psb_sspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) end function psb_s_linmap end interface @@ -137,11 +137,9 @@ module psb_s_linmap_mod contains function s_map_sizeof(map) result(val) - use psb_desc_mod - use psb_s_mat_mod implicit none class(psb_slinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = map%psb_base_linmap_type%sizeof() val = val + map%map_X2Y%sizeof() @@ -151,7 +149,6 @@ contains function s_is_asb(map) result(val) - use psb_desc_mod implicit none class(psb_slinmap_type), intent(in) :: map logical :: val @@ -163,8 +160,6 @@ contains subroutine psb_s_map_cscnv(map,info,type,mold,imold) - use psb_i_vect_mod - use psb_s_mat_mod implicit none class(psb_slinmap_type), intent(inout) :: map integer(psb_ipk_), intent(out) :: info @@ -185,20 +180,17 @@ contains subroutine psb_s_linmap_sub(out_map,map_kind,desc_X, desc_Y,& & map_X2Y, map_Y2X,iaggr,naggr) - use psb_s_mat_mod implicit none type(psb_slinmap_type), intent(out) :: out_map type(psb_desc_type), target :: desc_X, desc_Y type(psb_sspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr) end subroutine psb_s_linmap_sub subroutine psb_slinmap_transfer(mapin,mapout,info) use psb_realloc_mod - use psb_desc_mod - use psb_mat_mod, only : psb_move_alloc implicit none type(psb_slinmap_type) :: mapin,mapout integer(psb_ipk_), intent(out) :: info @@ -211,7 +203,6 @@ contains end subroutine psb_slinmap_transfer subroutine s_free(map,info) - use psb_desc_mod implicit none class(psb_slinmap_type) :: map integer(psb_ipk_), intent(out) :: info @@ -225,7 +216,6 @@ contains subroutine s_clone(map,mapout,info) - use psb_desc_mod use psb_error_mod implicit none class(psb_slinmap_type), intent(inout) :: map @@ -233,7 +223,6 @@ contains integer(psb_ipk_) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='clone' info = 0 @@ -247,9 +236,8 @@ contains if (info == 0) call map%map_Y2X%clone(mout%map_Y2X,info) class default info = psb_err_invalid_dynamic_type_ - ierr(1) = 2 info = psb_err_missing_override_method_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/2/)) call psb_erractionsave(err_act) call psb_error_handler(err_act) diff --git a/base/modules/comm/psb_z_comm_a_mod.f90 b/base/modules/comm/psb_z_comm_a_mod.f90 new file mode 100644 index 000000000..0c276945e --- /dev/null +++ b/base/modules/comm/psb_z_comm_a_mod.f90 @@ -0,0 +1,122 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psb_z_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_ + + interface psb_ovrl + subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) + import + implicit none + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode + end subroutine psb_zovrlm + subroutine psb_zovrlv(x,desc_a,info,work,update,mode) + import + implicit none + complex(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), intent(inout), optional, target :: work(:) + integer(psb_ipk_), intent(in), optional :: update,mode + end subroutine psb_zovrlv + end interface psb_ovrl + + interface psb_halo + subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data) + import + implicit none + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data + character, intent(in), optional :: tran + end subroutine psb_zhalom + subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data) + import + implicit none + complex(psb_dpk_), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), target, optional, intent(inout) :: work(:) + integer(psb_ipk_), intent(in), optional :: mode,data + character, intent(in), optional :: tran + end subroutine psb_zhalov + end interface psb_halo + + + interface psb_scatter + subroutine psb_zscatterm(globx, locx, desc_a, info, root) + import + implicit none + complex(psb_dpk_), intent(out), allocatable :: locx(:,:) + complex(psb_dpk_), intent(in) :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_zscatterm + subroutine psb_zscatterv(globx, locx, desc_a, info, root) + import + implicit none + complex(psb_dpk_), intent(out), allocatable :: locx(:) + complex(psb_dpk_), intent(in) :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_zscatterv + end interface psb_scatter + + interface psb_gather + subroutine psb_zgatherm(globx, locx, desc_a, info, root) + import + implicit none + complex(psb_dpk_), intent(in) :: locx(:,:) + complex(psb_dpk_), intent(out), allocatable :: globx(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_zgatherm + subroutine psb_zgatherv(globx, locx, desc_a, info, root) + import + implicit none + complex(psb_dpk_), intent(in) :: locx(:) + complex(psb_dpk_), intent(out), allocatable :: globx(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root + end subroutine psb_zgatherv + end interface psb_gather + +end module psb_z_comm_a_mod diff --git a/base/modules/comm/psb_z_comm_mod.f90 b/base/modules/comm/psb_z_comm_mod.f90 index e4a6e9ea1..58aabba29 100644 --- a/base/modules/comm/psb_z_comm_mod.f90 +++ b/base/modules/comm/psb_z_comm_mod.f90 @@ -31,30 +31,12 @@ ! module psb_z_comm_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_ - use psb_mat_mod, only : psb_zspmat_type + use psb_mat_mod, only : psb_zspmat_type, psb_lzspmat_type use psb_z_vect_mod, only : psb_z_vect_type, psb_z_base_vect_type use psb_z_multivect_mod, only : psb_z_multivect_type, psb_z_base_multivect_type interface psb_ovrl - subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update,mode) - import - implicit none - complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,jx,ik,mode - end subroutine psb_zovrlm - subroutine psb_zovrlv(x,desc_a,info,work,update,mode) - import - implicit none - complex(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), intent(inout), optional, target :: work(:) - integer(psb_ipk_), intent(in), optional :: update,mode - end subroutine psb_zovrlv subroutine psb_zovrl_vect(x,desc_a,info,work,update,mode) import implicit none @@ -76,26 +58,6 @@ module psb_z_comm_mod end interface psb_ovrl interface psb_halo - subroutine psb_zhalom(x,desc_a,info,jx,ik,work,tran,mode,data) - import - implicit none - complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,jx,ik,data - character, intent(in), optional :: tran - end subroutine psb_zhalom - subroutine psb_zhalov(x,desc_a,info,work,tran,mode,data) - import - implicit none - complex(psb_dpk_), intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_), target, optional, intent(inout) :: work(:) - integer(psb_ipk_), intent(in), optional :: mode,data - character, intent(in), optional :: tran - end subroutine psb_zhalov subroutine psb_zhalo_vect(x,desc_a,info,work,tran,mode,data) import implicit none @@ -120,24 +82,6 @@ module psb_z_comm_mod interface psb_scatter - subroutine psb_zscatterm(globx, locx, desc_a, info, root) - import - implicit none - complex(psb_dpk_), intent(out), allocatable :: locx(:,:) - complex(psb_dpk_), intent(in) :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_zscatterm - subroutine psb_zscatterv(globx, locx, desc_a, info, root) - import - implicit none - complex(psb_dpk_), intent(out), allocatable :: locx(:) - complex(psb_dpk_), intent(in) :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_zscatterv subroutine psb_zscatter_vect(globx, locx, desc_a, info, root, mold) import implicit none @@ -161,24 +105,26 @@ module psb_z_comm_mod integer(psb_ipk_), intent(in), optional :: root,dupl logical, intent(in), optional :: keepnum,keeploc end subroutine psb_zsp_allgather - subroutine psb_zgatherm(globx, locx, desc_a, info, root) + subroutine psb_lzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) import implicit none - complex(psb_dpk_), intent(in) :: locx(:,:) - complex(psb_dpk_), intent(out), allocatable :: globx(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_zgatherm - subroutine psb_zgatherv(globx, locx, desc_a, info, root) + type(psb_zspmat_type), intent(inout) :: loca + type(psb_lzspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lzsp_allgather + subroutine psb_lzlzsp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) import implicit none - complex(psb_dpk_), intent(in) :: locx(:) - complex(psb_dpk_), intent(out), allocatable :: globx(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: root - end subroutine psb_zgatherv + type(psb_lzspmat_type), intent(inout) :: loca + type(psb_lzspmat_type), intent(out) :: globa + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: root,dupl + logical, intent(in), optional :: keepnum,keeploc + end subroutine psb_lzlzsp_allgather subroutine psb_zgather_vect(globx, locx, desc_a, info, root) import implicit none diff --git a/base/modules/comm/psb_z_linmap_mod.f90 b/base/modules/comm/psb_z_linmap_mod.f90 index d71594330..1900ecb00 100644 --- a/base/modules/comm/psb_z_linmap_mod.f90 +++ b/base/modules/comm/psb_z_linmap_mod.f90 @@ -38,8 +38,8 @@ module psb_z_linmap_mod use psb_const_mod - use psb_z_mat_mod, only : psb_zspmat_type - use psb_desc_mod, only : psb_desc_type + use psb_z_mat_mod + use psb_desc_mod use psb_base_linmap_mod @@ -118,13 +118,13 @@ module psb_z_linmap_mod interface psb_linmap function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) use psb_z_mat_mod, only : psb_zspmat_type - import :: psb_ipk_, psb_zlinmap_type, psb_desc_type + import :: psb_ipk_, psb_zlinmap_type, psb_desc_type, psb_lpk_ implicit none type(psb_zlinmap_type) :: psb_z_linmap type(psb_desc_type), target :: desc_X, desc_Y type(psb_zspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) end function psb_z_linmap end interface @@ -137,11 +137,9 @@ module psb_z_linmap_mod contains function z_map_sizeof(map) result(val) - use psb_desc_mod - use psb_z_mat_mod implicit none class(psb_zlinmap_type), intent(in) :: map - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = map%psb_base_linmap_type%sizeof() val = val + map%map_X2Y%sizeof() @@ -151,7 +149,6 @@ contains function z_is_asb(map) result(val) - use psb_desc_mod implicit none class(psb_zlinmap_type), intent(in) :: map logical :: val @@ -163,8 +160,6 @@ contains subroutine psb_z_map_cscnv(map,info,type,mold,imold) - use psb_i_vect_mod - use psb_z_mat_mod implicit none class(psb_zlinmap_type), intent(inout) :: map integer(psb_ipk_), intent(out) :: info @@ -185,20 +180,17 @@ contains subroutine psb_z_linmap_sub(out_map,map_kind,desc_X, desc_Y,& & map_X2Y, map_Y2X,iaggr,naggr) - use psb_z_mat_mod implicit none type(psb_zlinmap_type), intent(out) :: out_map type(psb_desc_type), target :: desc_X, desc_Y type(psb_zspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr) end subroutine psb_z_linmap_sub subroutine psb_zlinmap_transfer(mapin,mapout,info) use psb_realloc_mod - use psb_desc_mod - use psb_mat_mod, only : psb_move_alloc implicit none type(psb_zlinmap_type) :: mapin,mapout integer(psb_ipk_), intent(out) :: info @@ -211,7 +203,6 @@ contains end subroutine psb_zlinmap_transfer subroutine z_free(map,info) - use psb_desc_mod implicit none class(psb_zlinmap_type) :: map integer(psb_ipk_), intent(out) :: info @@ -225,7 +216,6 @@ contains subroutine z_clone(map,mapout,info) - use psb_desc_mod use psb_error_mod implicit none class(psb_zlinmap_type), intent(inout) :: map @@ -233,7 +223,6 @@ contains integer(psb_ipk_) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='clone' info = 0 @@ -247,9 +236,8 @@ contains if (info == 0) call map%map_Y2X%clone(mout%map_Y2X,info) class default info = psb_err_invalid_dynamic_type_ - ierr(1) = 2 info = psb_err_missing_override_method_ - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,m_err=(/2/)) call psb_erractionsave(err_act) call psb_error_handler(err_act) diff --git a/base/modules/comm/psi_c_comm_a_mod.f90 b/base/modules/comm/psi_c_comm_a_mod.f90 new file mode 100644 index 000000000..030d74657 --- /dev/null +++ b/base/modules/comm/psi_c_comm_a_mod.f90 @@ -0,0 +1,166 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_c_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type + + interface psi_swapdata + subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_cswapdatam + subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_cswapdatav + subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_cswapidxm + subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_cswapidxv + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_cswaptranm + subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_cswaptranv + subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:,:), beta + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_ctranidxm + subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: y(:), beta + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_ctranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_covrl_updr1(x,desc_a,update,info) + import + complex(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_updr1 + subroutine psi_covrl_updr2(x,desc_a,update,info) + import + complex(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_covrl_saver1(x,xs,desc_a,info) + import + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_saver1 + subroutine psi_covrl_saver2(x,xs,desc_a,info) + import + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_covrl_restrr1(x,xs,desc_a,info) + import + complex(psb_spk_), intent(inout) :: x(:) + complex(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_restrr1 + subroutine psi_covrl_restrr2(x,xs,desc_a,info) + import + complex(psb_spk_), intent(inout) :: x(:,:) + complex(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_covrl_restrr2 + end interface psi_ovrl_restore + +end module psi_c_comm_a_mod + diff --git a/base/modules/psi_c_mod.f90 b/base/modules/comm/psi_c_comm_v_mod.f90 similarity index 60% rename from base/modules/psi_c_mod.f90 rename to base/modules/comm/psi_c_comm_v_mod.f90 index 19ca1fd05..78fee8aea 100644 --- a/base/modules/psi_c_mod.f90 +++ b/base/modules/comm/psi_c_comm_v_mod.f90 @@ -29,31 +29,12 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -module psi_c_mod +module psi_c_comm_v_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type use psb_c_base_vect_mod, only : psb_c_base_vect_type use psb_c_base_multivect_mod, only : psb_c_base_multivect_type - interface psi_swapdata - subroutine psi_cswapdatam(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_cswapdatam - subroutine psi_cswapdatav(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_cswapdatav subroutine psi_cswapdata_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -74,24 +55,6 @@ module psi_c_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswapdata_multivect - subroutine psi_cswapidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_cswapidxm - subroutine psi_cswapidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_cswapidxv subroutine psi_cswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -118,24 +81,6 @@ module psi_c_mod interface psi_swaptran - subroutine psi_cswaptranm(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_cswaptranm - subroutine psi_cswaptranv(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_cswaptranv subroutine psi_cswaptran_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -156,24 +101,6 @@ module psi_c_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_cswaptran_multivect - subroutine psi_ctranidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:,:), beta - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_ctranidxm - subroutine psi_ctranidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - complex(psb_spk_) :: y(:), beta - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_ctranidxv subroutine psi_ctran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -199,20 +126,6 @@ module psi_c_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_covrl_updr1(x,desc_a,update,info) - import - complex(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_covrl_updr1 - subroutine psi_covrl_updr2(x,desc_a,update,info) - import - complex(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_covrl_updr2 subroutine psi_covrl_upd_vect(x,desc_a,update,info) import class(psb_c_base_vect_type) :: x @@ -230,20 +143,6 @@ module psi_c_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_covrl_saver1(x,xs,desc_a,info) - import - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_covrl_saver1 - subroutine psi_covrl_saver2(x,xs,desc_a,info) - import - complex(psb_spk_), intent(inout) :: x(:,:) - complex(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_covrl_saver2 subroutine psi_covrl_save_vect(x,xs,desc_a,info) import class(psb_c_base_vect_type) :: x @@ -261,20 +160,6 @@ module psi_c_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_covrl_restrr1(x,xs,desc_a,info) - import - complex(psb_spk_), intent(inout) :: x(:) - complex(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_covrl_restrr1 - subroutine psi_covrl_restrr2(x,xs,desc_a,info) - import - complex(psb_spk_), intent(inout) :: x(:,:) - complex(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_covrl_restrr2 subroutine psi_covrl_restr_vect(x,xs,desc_a,info) import class(psb_c_base_vect_type) :: x @@ -291,5 +176,5 @@ module psi_c_mod end subroutine psi_covrl_restr_multivect end interface psi_ovrl_restore -end module psi_c_mod +end module psi_c_comm_v_mod diff --git a/base/modules/comm/psi_d_comm_a_mod.f90 b/base/modules/comm/psi_d_comm_a_mod.f90 new file mode 100644 index 000000000..43b74b1d9 --- /dev/null +++ b/base/modules/comm/psi_d_comm_a_mod.f90 @@ -0,0 +1,166 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_d_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type + + interface psi_swapdata + subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_dswapdatam + subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_dswapdatav + subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_dswapidxm + subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_dswapidxv + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_dswaptranm + subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_dswaptranv + subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:,:), beta + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_dtranidxm + subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: y(:), beta + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_dtranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_dovrl_updr1(x,desc_a,update,info) + import + real(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_updr1 + subroutine psi_dovrl_updr2(x,desc_a,update,info) + import + real(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_dovrl_saver1(x,xs,desc_a,info) + import + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_saver1 + subroutine psi_dovrl_saver2(x,xs,desc_a,info) + import + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_dovrl_restrr1(x,xs,desc_a,info) + import + real(psb_dpk_), intent(inout) :: x(:) + real(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_restrr1 + subroutine psi_dovrl_restrr2(x,xs,desc_a,info) + import + real(psb_dpk_), intent(inout) :: x(:,:) + real(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_dovrl_restrr2 + end interface psi_ovrl_restore + +end module psi_d_comm_a_mod + diff --git a/base/modules/psi_d_mod.f90 b/base/modules/comm/psi_d_comm_v_mod.f90 similarity index 61% rename from base/modules/psi_d_mod.f90 rename to base/modules/comm/psi_d_comm_v_mod.f90 index a31d8f289..41aeab6fd 100644 --- a/base/modules/psi_d_mod.f90 +++ b/base/modules/comm/psi_d_comm_v_mod.f90 @@ -29,31 +29,12 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -module psi_d_mod +module psi_d_comm_v_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type use psb_d_base_vect_mod, only : psb_d_base_vect_type use psb_d_base_multivect_mod, only : psb_d_base_multivect_type - interface psi_swapdata - subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_dswapdatam - subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_dswapdatav subroutine psi_dswapdata_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -74,24 +55,6 @@ module psi_d_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswapdata_multivect - subroutine psi_dswapidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_dswapidxm - subroutine psi_dswapidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_dswapidxv subroutine psi_dswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -118,24 +81,6 @@ module psi_d_mod interface psi_swaptran - subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_dswaptranm - subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_dswaptranv subroutine psi_dswaptran_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -156,24 +101,6 @@ module psi_d_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_dswaptran_multivect - subroutine psi_dtranidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:,:), beta - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_dtranidxm - subroutine psi_dtranidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - real(psb_dpk_) :: y(:), beta - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_dtranidxv subroutine psi_dtran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -199,20 +126,6 @@ module psi_d_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_dovrl_updr1(x,desc_a,update,info) - import - real(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_dovrl_updr1 - subroutine psi_dovrl_updr2(x,desc_a,update,info) - import - real(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_dovrl_updr2 subroutine psi_dovrl_upd_vect(x,desc_a,update,info) import class(psb_d_base_vect_type) :: x @@ -230,20 +143,6 @@ module psi_d_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_dovrl_saver1(x,xs,desc_a,info) - import - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_dovrl_saver1 - subroutine psi_dovrl_saver2(x,xs,desc_a,info) - import - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_dovrl_saver2 subroutine psi_dovrl_save_vect(x,xs,desc_a,info) import class(psb_d_base_vect_type) :: x @@ -261,20 +160,6 @@ module psi_d_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_dovrl_restrr1(x,xs,desc_a,info) - import - real(psb_dpk_), intent(inout) :: x(:) - real(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_dovrl_restrr1 - subroutine psi_dovrl_restrr2(x,xs,desc_a,info) - import - real(psb_dpk_), intent(inout) :: x(:,:) - real(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_dovrl_restrr2 subroutine psi_dovrl_restr_vect(x,xs,desc_a,info) import class(psb_d_base_vect_type) :: x @@ -291,5 +176,5 @@ module psi_d_mod end subroutine psi_dovrl_restr_multivect end interface psi_ovrl_restore -end module psi_d_mod +end module psi_d_comm_v_mod diff --git a/base/modules/comm/psi_e_comm_a_mod.f90 b/base/modules/comm/psi_e_comm_a_mod.f90 new file mode 100644 index 000000000..98522486f --- /dev/null +++ b/base/modules/comm/psi_e_comm_a_mod.f90 @@ -0,0 +1,166 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_e_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_ + + interface psi_swapdata + subroutine psi_eswapdatam(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_eswapdatam + subroutine psi_eswapdatav(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_eswapdatav + subroutine psi_eswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_eswapidxm + subroutine psi_eswapidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_eswapidxv + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_eswaptranm(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_eswaptranm + subroutine psi_eswaptranv(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_eswaptranv + subroutine psi_etranidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:,:), beta + integer(psb_epk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_etranidxm + subroutine psi_etranidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_epk_) :: y(:), beta + integer(psb_epk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_etranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_eovrl_updr1(x,desc_a,update,info) + import + integer(psb_epk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_eovrl_updr1 + subroutine psi_eovrl_updr2(x,desc_a,update,info) + import + integer(psb_epk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_eovrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_eovrl_saver1(x,xs,desc_a,info) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_eovrl_saver1 + subroutine psi_eovrl_saver2(x,xs,desc_a,info) + import + integer(psb_epk_), intent(inout) :: x(:,:) + integer(psb_epk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_eovrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_eovrl_restrr1(x,xs,desc_a,info) + import + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_eovrl_restrr1 + subroutine psi_eovrl_restrr2(x,xs,desc_a,info) + import + integer(psb_epk_), intent(inout) :: x(:,:) + integer(psb_epk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_eovrl_restrr2 + end interface psi_ovrl_restore + +end module psi_e_comm_a_mod + diff --git a/base/modules/comm/psi_i_comm_v_mod.f90 b/base/modules/comm/psi_i_comm_v_mod.f90 new file mode 100644 index 000000000..91b2f85a6 --- /dev/null +++ b/base/modules/comm/psi_i_comm_v_mod.f90 @@ -0,0 +1,180 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_i_comm_v_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_ + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_i_base_multivect_mod, only : psb_i_base_multivect_type + + interface psi_swapdata + subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswapdata_vect + subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswapdata_multivect + subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_iswap_vidx_vect + subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_iswap_vidx_multivect + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswaptran_vect + subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_iswaptran_multivect + subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_itran_vidx_vect + subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_multivect_type) :: y + integer(psb_ipk_) :: beta + integer(psb_ipk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_itran_vidx_multivect + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_iovrl_upd_vect(x,desc_a,update,info) + import + class(psb_i_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_upd_vect + subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) + import + class(psb_i_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_upd_multivect + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_iovrl_save_vect(x,xs,desc_a,info) + import + class(psb_i_base_vect_type) :: x + integer(psb_ipk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_save_vect + subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) + import + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_save_multivect + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) + import + class(psb_i_base_vect_type) :: x + integer(psb_ipk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_restr_vect + subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) + import + class(psb_i_base_multivect_type) :: x + integer(psb_ipk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_iovrl_restr_multivect + end interface psi_ovrl_restore + +end module psi_i_comm_v_mod + diff --git a/base/modules/comm/psi_l_comm_v_mod.f90 b/base/modules/comm/psi_l_comm_v_mod.f90 new file mode 100644 index 000000000..150c5bd45 --- /dev/null +++ b/base/modules/comm/psi_l_comm_v_mod.f90 @@ -0,0 +1,181 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_l_comm_v_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_lpk_, psb_epk_, psb_i_base_vect_type + use psb_l_base_vect_mod, only : psb_l_base_vect_type + use psb_l_base_multivect_mod, only : psb_l_base_multivect_type + + interface psi_swapdata + subroutine psi_lswapdata_vect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_lswapdata_vect + subroutine psi_lswapdata_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_lswapdata_multivect + subroutine psi_lswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_lswap_vidx_vect + subroutine psi_lswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_lswap_vidx_multivect + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_lswaptran_vect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_lswaptran_vect + subroutine psi_lswaptran_multivect(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_lswaptran_multivect + subroutine psi_ltran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_ltran_vidx_vect + subroutine psi_ltran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type) :: y + integer(psb_lpk_) :: beta + integer(psb_lpk_), target :: work(:) + class(psb_i_base_vect_type), intent(inout) :: idx + integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv + end subroutine psi_ltran_vidx_multivect + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_lovrl_upd_vect(x,desc_a,update,info) + import + class(psb_l_base_vect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_upd_vect + subroutine psi_lovrl_upd_multivect(x,desc_a,update,info) + import + class(psb_l_base_multivect_type) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_upd_multivect + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_lovrl_save_vect(x,xs,desc_a,info) + import + class(psb_l_base_vect_type) :: x + integer(psb_lpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_save_vect + subroutine psi_lovrl_save_multivect(x,xs,desc_a,info) + import + class(psb_l_base_multivect_type) :: x + integer(psb_lpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_save_multivect + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_lovrl_restr_vect(x,xs,desc_a,info) + import + class(psb_l_base_vect_type) :: x + integer(psb_lpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_restr_vect + subroutine psi_lovrl_restr_multivect(x,xs,desc_a,info) + import + class(psb_l_base_multivect_type) :: x + integer(psb_lpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_lovrl_restr_multivect + end interface psi_ovrl_restore + +end module psi_l_comm_v_mod + diff --git a/base/modules/comm/psi_m_comm_a_mod.f90 b/base/modules/comm/psi_m_comm_a_mod.f90 new file mode 100644 index 000000000..4d0608c30 --- /dev/null +++ b/base/modules/comm/psi_m_comm_a_mod.f90 @@ -0,0 +1,166 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_m_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_ + + interface psi_swapdata + subroutine psi_mswapdatam(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_mswapdatam + subroutine psi_mswapdatav(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_mswapdatav + subroutine psi_mswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_mswapidxm + subroutine psi_mswapidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_mswapidxv + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_mswaptranm(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_mswaptranm + subroutine psi_mswaptranv(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_mswaptranv + subroutine psi_mtranidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:,:), beta + integer(psb_mpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_mtranidxm + subroutine psi_mtranidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + integer(psb_mpk_) :: y(:), beta + integer(psb_mpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_mtranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_movrl_updr1(x,desc_a,update,info) + import + integer(psb_mpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_movrl_updr1 + subroutine psi_movrl_updr2(x,desc_a,update,info) + import + integer(psb_mpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_movrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_movrl_saver1(x,xs,desc_a,info) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_mpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_movrl_saver1 + subroutine psi_movrl_saver2(x,xs,desc_a,info) + import + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_mpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_movrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_movrl_restrr1(x,xs,desc_a,info) + import + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_mpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_movrl_restrr1 + subroutine psi_movrl_restrr2(x,xs,desc_a,info) + import + integer(psb_mpk_), intent(inout) :: x(:,:) + integer(psb_mpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_movrl_restrr2 + end interface psi_ovrl_restore + +end module psi_m_comm_a_mod + diff --git a/base/modules/comm/psi_s_comm_a_mod.f90 b/base/modules/comm/psi_s_comm_a_mod.f90 new file mode 100644 index 000000000..e3fdabb2f --- /dev/null +++ b/base/modules/comm/psi_s_comm_a_mod.f90 @@ -0,0 +1,166 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_s_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type + + interface psi_swapdata + subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_sswapdatam + subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_sswapdatav + subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_sswapidxm + subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_sswapidxv + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_sswaptranm + subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_sswaptranv + subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:,:), beta + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_stranidxm + subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: y(:), beta + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_stranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_sovrl_updr1(x,desc_a,update,info) + import + real(psb_spk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_updr1 + subroutine psi_sovrl_updr2(x,desc_a,update,info) + import + real(psb_spk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_sovrl_saver1(x,xs,desc_a,info) + import + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_saver1 + subroutine psi_sovrl_saver2(x,xs,desc_a,info) + import + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_sovrl_restrr1(x,xs,desc_a,info) + import + real(psb_spk_), intent(inout) :: x(:) + real(psb_spk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_restrr1 + subroutine psi_sovrl_restrr2(x,xs,desc_a,info) + import + real(psb_spk_), intent(inout) :: x(:,:) + real(psb_spk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_sovrl_restrr2 + end interface psi_ovrl_restore + +end module psi_s_comm_a_mod + diff --git a/base/modules/psi_s_mod.f90 b/base/modules/comm/psi_s_comm_v_mod.f90 similarity index 61% rename from base/modules/psi_s_mod.f90 rename to base/modules/comm/psi_s_comm_v_mod.f90 index 5da0a6022..9e7f525de 100644 --- a/base/modules/psi_s_mod.f90 +++ b/base/modules/comm/psi_s_comm_v_mod.f90 @@ -29,31 +29,12 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -module psi_s_mod +module psi_s_comm_v_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type use psb_s_base_vect_mod, only : psb_s_base_vect_type use psb_s_base_multivect_mod, only : psb_s_base_multivect_type - interface psi_swapdata - subroutine psi_sswapdatam(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_sswapdatam - subroutine psi_sswapdatav(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_sswapdatav subroutine psi_sswapdata_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -74,24 +55,6 @@ module psi_s_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswapdata_multivect - subroutine psi_sswapidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_sswapidxm - subroutine psi_sswapidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_sswapidxv subroutine psi_sswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -118,24 +81,6 @@ module psi_s_mod interface psi_swaptran - subroutine psi_sswaptranm(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_sswaptranm - subroutine psi_sswaptranv(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_sswaptranv subroutine psi_sswaptran_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -156,24 +101,6 @@ module psi_s_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_sswaptran_multivect - subroutine psi_stranidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:,:), beta - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_stranidxm - subroutine psi_stranidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - real(psb_spk_) :: y(:), beta - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_stranidxv subroutine psi_stran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -199,20 +126,6 @@ module psi_s_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_sovrl_updr1(x,desc_a,update,info) - import - real(psb_spk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_sovrl_updr1 - subroutine psi_sovrl_updr2(x,desc_a,update,info) - import - real(psb_spk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_sovrl_updr2 subroutine psi_sovrl_upd_vect(x,desc_a,update,info) import class(psb_s_base_vect_type) :: x @@ -230,20 +143,6 @@ module psi_s_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_sovrl_saver1(x,xs,desc_a,info) - import - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_sovrl_saver1 - subroutine psi_sovrl_saver2(x,xs,desc_a,info) - import - real(psb_spk_), intent(inout) :: x(:,:) - real(psb_spk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_sovrl_saver2 subroutine psi_sovrl_save_vect(x,xs,desc_a,info) import class(psb_s_base_vect_type) :: x @@ -261,20 +160,6 @@ module psi_s_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_sovrl_restrr1(x,xs,desc_a,info) - import - real(psb_spk_), intent(inout) :: x(:) - real(psb_spk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_sovrl_restrr1 - subroutine psi_sovrl_restrr2(x,xs,desc_a,info) - import - real(psb_spk_), intent(inout) :: x(:,:) - real(psb_spk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_sovrl_restrr2 subroutine psi_sovrl_restr_vect(x,xs,desc_a,info) import class(psb_s_base_vect_type) :: x @@ -291,5 +176,5 @@ module psi_s_mod end subroutine psi_sovrl_restr_multivect end interface psi_ovrl_restore -end module psi_s_mod +end module psi_s_comm_v_mod diff --git a/base/modules/comm/psi_z_comm_a_mod.f90 b/base/modules/comm/psi_z_comm_a_mod.f90 new file mode 100644 index 000000000..c3dcd8760 --- /dev/null +++ b/base/modules/comm/psi_z_comm_a_mod.f90 @@ -0,0 +1,166 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_z_comm_a_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type + + interface psi_swapdata + subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_zswapdatam + subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_zswapdatav + subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_zswapidxm + subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_zswapidxv + end interface psi_swapdata + + + interface psi_swaptran + subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_zswaptranm + subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) + import + integer(psb_ipk_), intent(in) :: flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_),target :: work(:) + type(psb_desc_type), target :: desc_a + integer(psb_ipk_), optional :: data + end subroutine psi_zswaptranv + subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:,:), beta + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_ztranidxm + subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,& + & totxch,totsnd,totrcv,work,info) + import + integer(psb_ipk_), intent(in) :: ictxt,icomm,flag + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: y(:), beta + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv + end subroutine psi_ztranidxv + end interface psi_swaptran + + interface psi_ovrl_upd + subroutine psi_zovrl_updr1(x,desc_a,update,info) + import + complex(psb_dpk_), intent(inout), target :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_updr1 + subroutine psi_zovrl_updr2(x,desc_a,update,info) + import + complex(psb_dpk_), intent(inout), target :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(in) :: update + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_updr2 + end interface psi_ovrl_upd + + interface psi_ovrl_save + subroutine psi_zovrl_saver1(x,xs,desc_a,info) + import + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_), allocatable :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_saver1 + subroutine psi_zovrl_saver2(x,xs,desc_a,info) + import + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_), allocatable :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_saver2 + end interface psi_ovrl_save + + interface psi_ovrl_restore + subroutine psi_zovrl_restrr1(x,xs,desc_a,info) + import + complex(psb_dpk_), intent(inout) :: x(:) + complex(psb_dpk_) :: xs(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_restrr1 + subroutine psi_zovrl_restrr2(x,xs,desc_a,info) + import + complex(psb_dpk_), intent(inout) :: x(:,:) + complex(psb_dpk_) :: xs(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_zovrl_restrr2 + end interface psi_ovrl_restore + +end module psi_z_comm_a_mod + diff --git a/base/modules/psi_z_mod.f90 b/base/modules/comm/psi_z_comm_v_mod.f90 similarity index 60% rename from base/modules/psi_z_mod.f90 rename to base/modules/comm/psi_z_comm_v_mod.f90 index e5bbc9f47..9e9816e6b 100644 --- a/base/modules/psi_z_mod.f90 +++ b/base/modules/comm/psi_z_comm_v_mod.f90 @@ -29,31 +29,12 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -module psi_z_mod +module psi_z_comm_v_mod use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type use psb_z_base_vect_mod, only : psb_z_base_vect_type use psb_z_base_multivect_mod, only : psb_z_base_multivect_type - interface psi_swapdata - subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_zswapdatam - subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_zswapdatav subroutine psi_zswapdata_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -74,24 +55,6 @@ module psi_z_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswapdata_multivect - subroutine psi_zswapidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_zswapidxm - subroutine psi_zswapidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_zswapidxv subroutine psi_zswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -118,24 +81,6 @@ module psi_z_mod interface psi_swaptran - subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_zswaptranm - subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_zswaptranv subroutine psi_zswaptran_vect(flag,beta,y,desc_a,work,info,data) import integer(psb_ipk_), intent(in) :: flag @@ -156,24 +101,6 @@ module psi_z_mod type(psb_desc_type), target :: desc_a integer(psb_ipk_), optional :: data end subroutine psi_zswaptran_multivect - subroutine psi_ztranidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:,:), beta - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_ztranidxm - subroutine psi_ztranidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - complex(psb_dpk_) :: y(:), beta - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_ztranidxv subroutine psi_ztran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& & totxch,totsnd,totrcv,work,info) import @@ -199,20 +126,6 @@ module psi_z_mod end interface psi_swaptran interface psi_ovrl_upd - subroutine psi_zovrl_updr1(x,desc_a,update,info) - import - complex(psb_dpk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_zovrl_updr1 - subroutine psi_zovrl_updr2(x,desc_a,update,info) - import - complex(psb_dpk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_zovrl_updr2 subroutine psi_zovrl_upd_vect(x,desc_a,update,info) import class(psb_z_base_vect_type) :: x @@ -230,20 +143,6 @@ module psi_z_mod end interface psi_ovrl_upd interface psi_ovrl_save - subroutine psi_zovrl_saver1(x,xs,desc_a,info) - import - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_zovrl_saver1 - subroutine psi_zovrl_saver2(x,xs,desc_a,info) - import - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_zovrl_saver2 subroutine psi_zovrl_save_vect(x,xs,desc_a,info) import class(psb_z_base_vect_type) :: x @@ -261,20 +160,6 @@ module psi_z_mod end interface psi_ovrl_save interface psi_ovrl_restore - subroutine psi_zovrl_restrr1(x,xs,desc_a,info) - import - complex(psb_dpk_), intent(inout) :: x(:) - complex(psb_dpk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_zovrl_restrr1 - subroutine psi_zovrl_restrr2(x,xs,desc_a,info) - import - complex(psb_dpk_), intent(inout) :: x(:,:) - complex(psb_dpk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_zovrl_restrr2 subroutine psi_zovrl_restr_vect(x,xs,desc_a,info) import class(psb_z_base_vect_type) :: x @@ -291,5 +176,5 @@ module psi_z_mod end subroutine psi_zovrl_restr_multivect end interface psi_ovrl_restore -end module psi_z_mod +end module psi_z_comm_v_mod diff --git a/base/modules/desc/psb_desc_const_mod.f90 b/base/modules/desc/psb_desc_const_mod.f90 index 26d633fbb..8c3937e01 100644 --- a/base/modules/desc/psb_desc_const_mod.f90 +++ b/base/modules/desc/psb_desc_const_mod.f90 @@ -35,7 +35,7 @@ ! Auxiliary module for descriptor: constant values. ! module psb_desc_const_mod - use psb_const_mod, only : psb_ipk_, psb_mpik_ + use psb_const_mod, only : psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ ! ! Communication, prolongation & restriction ! @@ -101,11 +101,11 @@ module psb_desc_const_mod ! ! Constants for hashing into desc%hashv(:) and desc%glb_lc(:,:) ! - integer(psb_ipk_), parameter :: psb_hash_bits=16 - integer(psb_ipk_), parameter :: psb_max_hash_bits=22 - integer(psb_ipk_), parameter :: psb_hash_size=2**psb_hash_bits, psb_hash_mask=psb_hash_size-1 + integer(psb_ipk_), parameter :: psb_hash_bits = 16 + integer(psb_ipk_), parameter :: psb_max_hash_bits = 22 + integer(psb_ipk_), parameter :: psb_hash_size = 2**psb_hash_bits, psb_hash_mask=psb_hash_size-1 integer(psb_ipk_), parameter :: psb_default_large_threshold=1*1024*1024 - integer(psb_ipk_), parameter :: psb_hpnt_nentries_=7 + integer(psb_ipk_), parameter :: psb_hpnt_nentries_ = 7 ! ! Constants for desc_a handling @@ -121,8 +121,8 @@ module psb_desc_const_mod interface subroutine psb_parts(glob_index,nrow,np,pv,nv) - import :: psb_ipk_ - integer(psb_ipk_), intent (in) :: glob_index, nrow + import :: psb_ipk_, psb_lpk_ + integer(psb_lpk_), intent (in) :: glob_index,nrow integer(psb_ipk_), intent (in) :: np integer(psb_ipk_), intent (out) :: nv, pv(*) end subroutine psb_parts diff --git a/base/modules/desc/psb_desc_mod.F90 b/base/modules/desc/psb_desc_mod.F90 index 63027d67b..01f913f11 100644 --- a/base/modules/desc/psb_desc_mod.F90 +++ b/base/modules/desc/psb_desc_mod.F90 @@ -278,13 +278,27 @@ module psb_desc_mod module procedure psb_cdtransfer end interface psb_move_alloc + interface psb_free + module procedure psb_cdfree + end interface psb_free + + interface psb_cd_set_large_threshold + module procedure psb_i_cd_set_large_threshold + end interface psb_cd_set_large_threshold + +#if defined(IPK4) && defined(LPK8) + interface psb_cd_set_large_threshold + module procedure psb_l_cd_set_large_threshold + end interface psb_cd_set_large_threshold +#endif + private :: nullify_desc, cd_get_fmt,& & cd_l2gs1, cd_l2gs2, cd_l2gv1, cd_l2gv2, cd_g2ls1,& & cd_g2ls2, cd_g2lv1, cd_g2lv2, cd_g2ls1_ins,& & cd_g2ls2_ins, cd_g2lv1_ins, cd_g2lv2_ins, cd_fnd_owner - integer(psb_ipk_), private, save :: cd_large_threshold=psb_default_large_threshold + integer(psb_lpk_), private, save :: cd_large_threshold=psb_default_large_threshold contains @@ -294,17 +308,17 @@ contains !....Parameters... class(psb_desc_type), intent(in) :: desc - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 - val = val + psb_sizeof_int*psb_size(desc%halo_index) - val = val + psb_sizeof_int*psb_size(desc%ext_index) - val = val + psb_sizeof_int*psb_size(desc%bnd_elem) - val = val + psb_sizeof_int*psb_size(desc%ovrlap_index) - val = val + psb_sizeof_int*psb_size(desc%ovrlap_elem) - val = val + psb_sizeof_int*psb_size(desc%ovr_mst_idx) - val = val + psb_sizeof_int*psb_size(desc%lprm) - val = val + psb_sizeof_int*psb_size(desc%idx_space) + val = val + psb_sizeof_ip*psb_size(desc%halo_index) + val = val + psb_sizeof_ip*psb_size(desc%ext_index) + val = val + psb_sizeof_ip*psb_size(desc%bnd_elem) + val = val + psb_sizeof_ip*psb_size(desc%ovrlap_index) + val = val + psb_sizeof_ip*psb_size(desc%ovrlap_elem) + val = val + psb_sizeof_ip*psb_size(desc%ovr_mst_idx) + val = val + psb_sizeof_ip*psb_size(desc%lprm) + val = val + psb_sizeof_ip*psb_size(desc%idx_space) if (allocated(desc%indxmap)) val = val + desc%indxmap%sizeof() val = val + desc%v_halo_index%sizeof() val = val + desc%v_ext_index%sizeof() @@ -315,13 +329,21 @@ contains - subroutine psb_cd_set_large_threshold(ith) + subroutine psb_i_cd_set_large_threshold(ith) implicit none integer(psb_ipk_), intent(in) :: ith if (ith > 0) then cd_large_threshold = ith end if - end subroutine psb_cd_set_large_threshold + end subroutine psb_i_cd_set_large_threshold + + subroutine psb_l_cd_set_large_threshold(ith) + implicit none + integer(psb_lpk_), intent(in) :: ith + if (ith > 0) then + cd_large_threshold = ith + end if + end subroutine psb_l_cd_set_large_threshold function psb_cd_get_large_threshold() result(val) implicit none @@ -333,7 +355,7 @@ contains use psb_penv_mod implicit none - integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: m logical :: val !locals val = (m > psb_cd_get_large_threshold()) @@ -344,7 +366,7 @@ contains implicit none integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: m logical :: val !locals integer(psb_ipk_) :: np,me @@ -480,7 +502,7 @@ contains function psb_cd_get_global_rows(desc) result(val) implicit none - integer(psb_ipk_) :: val + integer(psb_lpk_) :: val class(psb_desc_type), intent(in) :: desc if (allocated(desc%indxmap)) then @@ -493,7 +515,7 @@ contains function psb_cd_get_global_cols(desc) result(val) implicit none - integer(psb_ipk_) :: val + integer(psb_lpk_) :: val class(psb_desc_type), intent(in) :: desc if (allocated(desc%indxmap)) then @@ -506,7 +528,7 @@ contains function psb_cd_get_global_indices(desc,owned) result(val) implicit none - integer(psb_ipk_), allocatable :: val(:) + integer(psb_lpk_), allocatable :: val(:) class(psb_desc_type), intent(in) :: desc logical, intent(in), optional :: owned @@ -1078,7 +1100,6 @@ contains Subroutine psb_cd_get_recv_idx(tmp,desc,data,info) - use psb_error_mod use psb_penv_mod use psb_realloc_mod @@ -1090,8 +1111,8 @@ contains ! .. Local Scalars .. integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,& - & idx, gidx, proc, n_elem_send, n_elem_recv - integer(psb_ipk_), pointer :: idxlist(:) + & idx, proc, n_elem_send, n_elem_recv + integer(psb_ipk_), pointer :: idxlist(:) integer(psb_ipk_) :: debug_level, debug_unit, err_act character(len=20) :: name @@ -1139,7 +1160,7 @@ contains Do j=0,n_elem_recv-1 idx = idxlist(incnt+psb_elem_recv_+j) - call psb_ensure_size((outcnt+3),tmp,info,pad=-ione) + call psb_ensure_size((outcnt+3),tmp,info,pad=-1_psb_ipk_) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') @@ -1162,6 +1183,100 @@ contains return end Subroutine psb_cd_get_recv_idx + + Subroutine psb_cd_get_recv_idx_glob(tmp,desc,data,info) + + use psb_error_mod + use psb_penv_mod + use psb_realloc_mod + Implicit None + integer(psb_lpk_), allocatable, intent(out) :: tmp(:) + integer(psb_ipk_), intent(in) :: data + Type(psb_desc_type), Intent(in), target :: desc + integer(psb_ipk_), intent(out) :: info + + ! .. Local Scalars .. + integer(psb_ipk_) :: incnt, outcnt, j, np, me, ictxt, l_tmp,& + & idx, proc, n_elem_send, n_elem_recv + integer(psb_ipk_), pointer :: idxlist(:) + integer(psb_lpk_) :: gidx + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + name = 'psb_cd_get_recv_idx' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = psb_cd_get_context(desc) + call psb_info(ictxt, me, np) + + select case(data) + case(psb_comm_halo_) + idxlist => desc%halo_index + case(psb_comm_ovr_) + idxlist => desc%ovrlap_index + case(psb_comm_ext_) + idxlist => desc%ext_index + case(psb_comm_mov_) + idxlist => desc%ovr_mst_idx + write(psb_err_unit,*) 'Warning: unusual request getidx on ovr_mst_idx' + case default + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='wrong Data selector') + goto 9999 + end select + + l_tmp = 3*size(idxlist) + + allocate(tmp(l_tmp),stat=info) + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + + incnt = 1 + outcnt = 1 + tmp(:) = -1 + Do While (idxlist(incnt) /= -1) + proc = idxlist(incnt+psb_proc_id_) + n_elem_recv = idxlist(incnt+psb_n_elem_recv_) + n_elem_send = idxlist(incnt+n_elem_recv+psb_n_elem_send_) + + Do j=0,n_elem_recv-1 + idx = idxlist(incnt+psb_elem_recv_+j) + call psb_ensure_size((outcnt+3),tmp,info,pad=-1_psb_lpk_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_ensure_size') + goto 9999 + end if + call desc%indxmap%l2g(idx,gidx,info) + If (gidx < 0) then + info=-3 + call psb_errpush(info,name) + goto 9999 + endif + tmp(outcnt) = proc + tmp(outcnt+1) = 1 + tmp(outcnt+2) = gidx + tmp(outcnt+3) = -1 + + outcnt = outcnt+3 + end Do + incnt = incnt+n_elem_recv+n_elem_send+3 + end Do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + + end Subroutine psb_cd_get_recv_idx_glob subroutine psb_cd_cnv(desc, mold) class(psb_desc_type), intent(inout), target :: desc @@ -1179,7 +1294,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned @@ -1190,7 +1305,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%l2gs1(idx,info,mask=mask,owned=owned) + call desc%indxmap%l2gip(idx,info,mask=mask,owned=owned) else info = psb_err_invalid_cd_state_ end if @@ -1214,7 +1329,7 @@ contains implicit none class(psb_desc_type), intent(in) :: desc integer(psb_ipk_), intent(in) :: idxin - integer(psb_ipk_), intent(out) :: idxout + integer(psb_lpk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned @@ -1227,7 +1342,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%l2gs2(idxin,idxout,info,mask=mask,owned=owned) + call desc%indxmap%l2g(idxin,idxout,info,mask=mask,owned=owned) else info = psb_err_invalid_cd_state_ end if @@ -1250,7 +1365,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned @@ -1262,7 +1377,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%l2gv1(idx,info,mask=mask,owned=owned) + call desc%indxmap%l2gip(idx,info,mask=mask,owned=owned) else info = psb_err_invalid_cd_state_ end if @@ -1285,7 +1400,7 @@ contains implicit none class(psb_desc_type), intent(in) :: desc integer(psb_ipk_), intent(in) :: idxin(:) - integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_lpk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned @@ -1297,7 +1412,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%l2gv2(idxin,idxout,info,mask=mask,owned=owned) + call desc%indxmap%l2g(idxin,idxout,info,mask=mask,owned=owned) else info = psb_err_invalid_cd_state_ end if @@ -1320,7 +1435,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned @@ -1332,7 +1447,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%g2ls1(idx,info,mask=mask,owned=owned) + call desc%indxmap%g2lip(idx,info,mask=mask,owned=owned) else info = psb_err_invalid_cd_state_ end if @@ -1354,7 +1469,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask @@ -1368,7 +1483,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%g2ls2(idxin,idxout,info,mask=mask,owned=owned) + call desc%indxmap%g2l(idxin,idxout,info,mask=mask,owned=owned) else info = psb_err_invalid_cd_state_ end if @@ -1391,7 +1506,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned @@ -1403,7 +1518,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%g2lv1(idx,info,mask=mask,owned=owned) + call desc%indxmap%g2lip(idx,info,mask=mask,owned=owned) else info = psb_err_invalid_cd_state_ end if @@ -1425,7 +1540,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) @@ -1440,7 +1555,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%g2lv2(idxin,idxout,info,mask=mask,owned=owned) + call desc%indxmap%g2l(idxin,idxout,info,mask=mask,owned=owned) else info = psb_err_invalid_cd_state_ end if @@ -1464,7 +1579,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(inout) :: desc - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx @@ -1476,7 +1591,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%g2ls1_ins(idx,info,mask=mask,lidx=lidx) + call desc%indxmap%g2lip_ins(idx,info,mask=mask,lidx=lidx) else info = psb_err_invalid_cd_state_ end if @@ -1498,7 +1613,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(inout) :: desc - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask @@ -1513,7 +1628,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%g2ls2_ins(idxin,idxout,info,mask=mask,lidx=lidx) + call desc%indxmap%g2l_ins(idxin,idxout,info,mask=mask,lidx=lidx) else info = psb_err_invalid_cd_state_ end if @@ -1536,7 +1651,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(inout) :: desc - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) @@ -1550,7 +1665,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%g2lv1_ins(idx,info,mask=mask,lidx=lidx) + call desc%indxmap%g2lip_ins(idx,info,mask=mask,lidx=lidx) else info = psb_err_invalid_cd_state_ end if @@ -1572,7 +1687,7 @@ contains use psb_error_mod implicit none class(psb_desc_type), intent(inout) :: desc - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) @@ -1587,7 +1702,7 @@ contains call psb_erractionsave(err_act) if (allocated(desc%indxmap)) then - call desc%indxmap%g2lv2_ins(idxin,idxout,info,mask=mask,lidx=lidx) + call desc%indxmap%g2l_ins(idxin,idxout,info,mask=mask,lidx=lidx) else info = psb_err_invalid_cd_state_ end if @@ -1609,7 +1724,7 @@ contains subroutine cd_fnd_owner(idx,iprc,desc,info) use psb_error_mod implicit none - integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_desc_type), intent(in) :: desc integer(psb_ipk_), intent(out) :: info diff --git a/base/modules/desc/psb_gen_block_map_mod.f90 b/base/modules/desc/psb_gen_block_map_mod.f90 index 3366a2da6..a99a2eb1a 100644 --- a/base/modules/desc/psb_gen_block_map_mod.f90 +++ b/base/modules/desc/psb_gen_block_map_mod.f90 @@ -52,9 +52,9 @@ module psb_gen_block_map_mod use psb_hash_mod type, extends(psb_indx_map) :: psb_gen_block_map - integer(psb_ipk_) :: min_glob_row = -1 - integer(psb_ipk_) :: max_glob_row = -1 - integer(psb_ipk_), allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:) + integer(psb_lpk_) :: min_glob_row = -1 + integer(psb_lpk_) :: max_glob_row = -1 + integer(psb_lpk_), allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:) type(psb_hash_type) :: hash contains @@ -67,31 +67,53 @@ module psb_gen_block_map_mod procedure, pass(idxmap) :: reinit => block_reinit procedure, nopass :: get_fmt => block_get_fmt - procedure, pass(idxmap) :: l2gs1 => block_l2gs1 - procedure, pass(idxmap) :: l2gs2 => block_l2gs2 - procedure, pass(idxmap) :: l2gv1 => block_l2gv1 - procedure, pass(idxmap) :: l2gv2 => block_l2gv2 +!!$ procedure, pass(idxmap) :: l2gs1 => block_l2gs1 +!!$ procedure, pass(idxmap) :: l2gs2 => block_l2gs2 +!!$ procedure, pass(idxmap) :: l2gv1 => block_l2gv1 +!!$ procedure, pass(idxmap) :: l2gv2 => block_l2gv2 - procedure, pass(idxmap) :: g2ls1 => block_g2ls1 - procedure, pass(idxmap) :: g2ls2 => block_g2ls2 - procedure, pass(idxmap) :: g2lv1 => block_g2lv1 - procedure, pass(idxmap) :: g2lv2 => block_g2lv2 + procedure, pass(idxmap) :: ll2gs1 => block_ll2gs1 + procedure, pass(idxmap) :: ll2gs2 => block_ll2gs2 + procedure, pass(idxmap) :: ll2gv1 => block_ll2gv1 + procedure, pass(idxmap) :: ll2gv2 => block_ll2gv2 - procedure, pass(idxmap) :: g2ls1_ins => block_g2ls1_ins - procedure, pass(idxmap) :: g2ls2_ins => block_g2ls2_ins - procedure, pass(idxmap) :: g2lv1_ins => block_g2lv1_ins - procedure, pass(idxmap) :: g2lv2_ins => block_g2lv2_ins +!!$ procedure, pass(idxmap) :: g2ls1 => block_g2ls1 +!!$ procedure, pass(idxmap) :: g2ls2 => block_g2ls2 +!!$ procedure, pass(idxmap) :: g2lv1 => block_g2lv1 +!!$ procedure, pass(idxmap) :: g2lv2 => block_g2lv2 + + procedure, pass(idxmap) :: lg2ls1 => block_lg2ls1 + procedure, pass(idxmap) :: lg2ls2 => block_lg2ls2 + procedure, pass(idxmap) :: lg2lv1 => block_lg2lv1 + procedure, pass(idxmap) :: lg2lv2 => block_lg2lv2 + +!!$ procedure, pass(idxmap) :: g2ls1_ins => block_g2ls1_ins +!!$ procedure, pass(idxmap) :: g2ls2_ins => block_g2ls2_ins +!!$ procedure, pass(idxmap) :: g2lv1_ins => block_g2lv1_ins +!!$ procedure, pass(idxmap) :: g2lv2_ins => block_g2lv2_ins + + procedure, pass(idxmap) :: lg2ls1_ins => block_lg2ls1_ins + procedure, pass(idxmap) :: lg2ls2_ins => block_lg2ls2_ins + procedure, pass(idxmap) :: lg2lv1_ins => block_lg2lv1_ins + procedure, pass(idxmap) :: lg2lv2_ins => block_lg2lv2_ins procedure, pass(idxmap) :: fnd_owner => block_fnd_owner end type psb_gen_block_map private :: block_init, block_sizeof, block_asb, block_free,& - & block_get_fmt, block_l2gs1, block_l2gs2, block_l2gv1,& - & block_l2gv2, block_g2ls1, block_g2ls2, block_g2lv1,& - & block_g2lv2, block_g2ls1_ins, block_g2ls2_ins,& - & block_g2lv1_ins, block_g2lv2_ins, block_clone, block_reinit,& - & gen_block_search + & block_l2gs1, block_l2gs2, block_l2gv1, block_l2gv2, & + & block_ll2gs1, block_ll2gs2, block_ll2gv1, block_ll2gv2, & + & block_g2ls1, block_g2ls2, block_g2lv1, block_g2lv2, & + & block_g2ls1_ins, block_g2ls2_ins, block_g2lv1_ins, block_g2lv2_ins, & + & block_lg2ls1_ins, block_lg2ls2_ins, block_lg2lv1_ins, block_lg2lv2_ins, & + & block_clone, block_reinit,& + & block_get_fmt, gen_block_search, l_gen_block_search + + interface gen_block_search + module procedure l_gen_block_search +! module procedure gen_block_search, l_gen_block_search + end interface gen_block_search integer(psb_ipk_), private :: laddsz=500 @@ -101,16 +123,16 @@ contains function block_sizeof(idxmap) result(val) implicit none class(psb_gen_block_map), intent(in) :: idxmap - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = idxmap%psb_indx_map%sizeof() - val = val + 2 * psb_sizeof_int + val = val + 2 * psb_sizeof_lp if (allocated(idxmap%loc_to_glob)) & - & val = val + size(idxmap%loc_to_glob)*psb_sizeof_int + & val = val + size(idxmap%loc_to_glob)*psb_sizeof_lp if (allocated(idxmap%srt_l2g)) & - & val = val + size(idxmap%srt_l2g)*psb_sizeof_int + & val = val + size(idxmap%srt_l2g)*psb_sizeof_lp if (allocated(idxmap%vnl)) & - & val = val + size(idxmap%vnl)*psb_sizeof_int + & val = val + size(idxmap%vnl)*psb_sizeof_lp val = val + psb_sizeof(idxmap%hash) end function block_sizeof @@ -131,15 +153,173 @@ contains end subroutine block_free +!!$ +!!$ subroutine block_l2gs1(idx,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_gen_block_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: idxv(1) +!!$ info = 0 +!!$ if (present(mask)) then +!!$ if (.not.mask) return +!!$ end if +!!$ +!!$ idxv(1) = idx +!!$ call idxmap%l2gip(idxv,info,owned=owned) +!!$ idx = idxv(1) +!!$ +!!$ end subroutine block_l2gs1 +!!$ +!!$ subroutine block_l2gs2(idxin,idxout,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_gen_block_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin +!!$ integer(psb_ipk_), intent(out) :: idxout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ logical, intent(in), optional :: owned +!!$ +!!$ idxout = idxin +!!$ call idxmap%l2gip(idxout,info,mask,owned) +!!$ +!!$ end subroutine block_l2gs2 +!!$ +!!$ +!!$ subroutine block_l2gv1(idx,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_gen_block_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: i +!!$ logical :: owned_ +!!$ info = 0 +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < size(idx)) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(owned)) then +!!$ owned_ = owned +!!$ else +!!$ owned_ = .false. +!!$ end if +!!$ +!!$ if (present(mask)) then +!!$ +!!$ do i=1, size(idx) +!!$ if (mask(i)) then +!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then +!!$ idx(i) = idxmap%min_glob_row + idx(i) - 1 +!!$ else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& +!!$ & .and.(.not.owned_)) then +!!$ idx(i) = idxmap%loc_to_glob(idx(i)-idxmap%local_rows) +!!$ else +!!$ idx(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, size(idx) +!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%local_rows)) then +!!$ idx(i) = idxmap%min_glob_row + idx(i) - 1 +!!$ else if ((idxmap%local_rows < idx(i)).and.(idx(i) <= idxmap%local_cols)& +!!$ & .and.(.not.owned_)) then +!!$ idx(i) = idxmap%loc_to_glob(idx(i)-idxmap%local_rows) +!!$ else +!!$ idx(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end do +!!$ +!!$ end if +!!$ +!!$ end subroutine block_l2gv1 +!!$ +!!$ subroutine block_l2gv2(idxin,idxout,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_gen_block_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin(:) +!!$ integer(psb_ipk_), intent(out) :: idxout(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: is, im, i +!!$ logical :: owned_ +!!$ +!!$ info = 0 +!!$ +!!$ is = size(idxin) +!!$ im = min(is,size(idxout)) +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < im) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(owned)) then +!!$ owned_ = owned +!!$ else +!!$ owned_ = .false. +!!$ end if +!!$ +!!$ if (present(mask)) then +!!$ +!!$ do i=1, im +!!$ if (mask(i)) then +!!$ if ((1<=idxin(i)).and.(idxin(i) <= idxmap%local_rows)) then +!!$ idxout(i) = idxmap%min_glob_row + idxin(i) - 1 +!!$ else if ((idxmap%local_rows < idxin(i)).and.(idxin(i) <= idxmap%local_cols)& +!!$ & .and.(.not.owned_)) then +!!$ idxout(i) = idxmap%loc_to_glob(idxin(i)-idxmap%local_rows) +!!$ else +!!$ idxout(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, im +!!$ if ((1<=idxin(i)).and.(idxin(i) <= idxmap%local_rows)) then +!!$ idxout(i) = idxmap%min_glob_row + idxin(i) - 1 +!!$ else if ((idxmap%local_rows < idxin(i)).and.(idxin(i) <= idxmap%local_cols)& +!!$ & .and.(.not.owned_)) then +!!$ idxout(i) = idxmap%loc_to_glob(idxin(i)-idxmap%local_rows) +!!$ else +!!$ idxout(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end do +!!$ +!!$ end if +!!$ +!!$ if (is > im) then +!!$ info = -3 +!!$ end if +!!$ +!!$ end subroutine block_l2gv2 +!!$ - subroutine block_l2gs1(idx,idxmap,info,mask,owned) + subroutine block_ll2gs1(idx,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - integer(psb_ipk_) :: idxv(1) + integer(psb_lpk_) :: idxv(1) info = 0 if (present(mask)) then if (.not.mask) return @@ -149,13 +329,13 @@ contains call idxmap%l2gip(idxv,info,owned=owned) idx = idxv(1) - end subroutine block_l2gs1 + end subroutine block_ll2gs1 - subroutine block_l2gs2(idxin,idxout,idxmap,info,mask,owned) + subroutine block_ll2gs2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap integer(psb_ipk_), intent(in) :: idxin - integer(psb_ipk_), intent(out) :: idxout + integer(psb_lpk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned @@ -163,13 +343,13 @@ contains idxout = idxin call idxmap%l2gip(idxout,info,mask,owned) - end subroutine block_l2gs2 + end subroutine block_ll2gs2 - subroutine block_l2gv1(idx,idxmap,info,mask,owned) + subroutine block_ll2gv1(idx,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned @@ -221,13 +401,13 @@ contains end if - end subroutine block_l2gv1 + end subroutine block_ll2gv1 - subroutine block_l2gv2(idxin,idxout,idxmap,info,mask,owned) + subroutine block_ll2gv2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap integer(psb_ipk_), intent(in) :: idxin(:) - integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_lpk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned @@ -287,17 +467,279 @@ contains info = -3 end if - end subroutine block_l2gv2 + end subroutine block_ll2gv2 + +!!$ subroutine block_g2ls1(idx,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_gen_block_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: idxv(1) +!!$ info = 0 +!!$ +!!$ if (present(mask)) then +!!$ if (.not.mask) return +!!$ end if +!!$ +!!$ idxv(1) = idx +!!$ call idxmap%g2lip(idxv,info,owned=owned) +!!$ idx = idxv(1) +!!$ +!!$ end subroutine block_g2ls1 +!!$ +!!$ subroutine block_g2ls2(idxin,idxout,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_gen_block_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin +!!$ integer(psb_ipk_), intent(out) :: idxout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ logical, intent(in), optional :: owned +!!$ +!!$ idxout = idxin +!!$ call idxmap%g2lip(idxout,info,mask,owned) +!!$ +!!$ end subroutine block_g2ls2 +!!$ +!!$ +!!$ subroutine block_g2lv1(idx,idxmap,info,mask,owned) +!!$ use psb_penv_mod +!!$ use psb_sort_mod +!!$ implicit none +!!$ class(psb_gen_block_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: i, nv, is, ip, lip +!!$ integer(psb_lpk_) :: tidx +!!$ integer(psb_mpk_) :: ictxt, iam, np +!!$ logical :: owned_ +!!$ +!!$ info = 0 +!!$ ictxt = idxmap%get_ctxt() +!!$ call psb_info(ictxt,iam,np) +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < size(idx)) then +!!$! !$ write(0,*) 'Block g2l: size of mask', size(mask),size(idx) +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(owned)) then +!!$ owned_ = owned +!!$ else +!!$ owned_ = .false. +!!$ end if +!!$ +!!$ is = size(idx) +!!$ if (present(mask)) then +!!$ +!!$ if (idxmap%is_asb()) then +!!$ do i=1, is +!!$ if (mask(i)) then +!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then +!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& +!!$ &.and.(.not.owned_)) then +!!$ nv = size(idxmap%srt_l2g,1) +!!$ tidx = idx(i) +!!$ idx(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) +!!$ if (idx(i) > 0) idx(i) = idxmap%srt_l2g(idx(i),2)+idxmap%local_rows +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ else if (idxmap%is_valid()) then +!!$ do i=1,is +!!$ if (mask(i)) then +!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then +!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& +!!$ &.and.(.not.owned_)) then +!!$ ip = idx(i) +!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info) +!!$ if (lip > 0) idx(i) = lip + idxmap%local_rows +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ else +!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state() +!!$ idx(1:is) = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ if (idxmap%is_asb()) then +!!$ do i=1, is +!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then +!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& +!!$ &.and.(.not.owned_)) then +!!$ nv = size(idxmap%srt_l2g,1) +!!$ tidx = idx(i) +!!$ idx(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) +!!$ if (idx(i) > 0) idx(i) = idxmap%srt_l2g(idx(i),2)+idxmap%local_rows +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end do +!!$ +!!$ else if (idxmap%is_valid()) then +!!$ do i=1,is +!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then +!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& +!!$ &.and.(.not.owned_)) then +!!$ ip = idx(i) +!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info) +!!$ if (lip > 0) idx(i) = lip + idxmap%local_rows +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end do +!!$ else +!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state() +!!$ idx(1:is) = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ end if +!!$ +!!$ end subroutine block_g2lv1 +!!$ +!!$ subroutine block_g2lv2(idxin,idxout,idxmap,info,mask,owned) +!!$ use psb_penv_mod +!!$ use psb_sort_mod +!!$ implicit none +!!$ class(psb_gen_block_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin(:) +!!$ integer(psb_ipk_), intent(out) :: idxout(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ logical, intent(in), optional :: owned +!!$ +!!$ integer(psb_ipk_) :: i, nv, is, ip, lip, im +!!$ integer(psb_lpk_) :: tidx +!!$ integer(psb_mpk_) :: ictxt, iam, np +!!$ logical :: owned_ +!!$ +!!$ info = 0 +!!$ ictxt = idxmap%get_ctxt() +!!$ call psb_info(ictxt,iam,np) +!!$ is = size(idxin) +!!$ im = min(is,size(idxout)) +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < im) then +!!$! !$ write(0,*) 'Block g2l: size of mask', size(mask),size(idx) +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(owned)) then +!!$ owned_ = owned +!!$ else +!!$ owned_ = .false. +!!$ end if +!!$ +!!$ if (present(mask)) then +!!$ +!!$ if (idxmap%is_asb()) then +!!$ do i=1, im +!!$ if (mask(i)) then +!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then +!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& +!!$ &.and.(.not.owned_)) then +!!$ nv = size(idxmap%srt_l2g,1) +!!$ tidx = idxin(i) +!!$ idxout(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) +!!$ if (idxout(i) > 0) idxout(i) = idxmap%srt_l2g(idxout(i),2)+idxmap%local_rows +!!$ else +!!$ idxout(i) = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ else if (idxmap%is_valid()) then +!!$ do i=1,im +!!$ if (mask(i)) then +!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then +!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& +!!$ &.and.(.not.owned_)) then +!!$ ip = idxin(i) +!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info) +!!$ if (lip > 0) idxout(i) = lip + idxmap%local_rows +!!$ else +!!$ idxout(i) = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ else +!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state() +!!$ idxout(1:im) = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ if (idxmap%is_asb()) then +!!$ do i=1, im +!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then +!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& +!!$ &.and.(.not.owned_)) then +!!$ nv = size(idxmap%srt_l2g,1) +!!$ tidx = idxin(i) +!!$ idxout(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) +!!$ if (idxout(i) > 0) idxout(i) = idxmap%srt_l2g(idxout(i),2)+idxmap%local_rows +!!$ else +!!$ idxout(i) = -1 +!!$ end if +!!$ end do +!!$ +!!$ else if (idxmap%is_valid()) then +!!$ do i=1,im +!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then +!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& +!!$ &.and.(.not.owned_)) then +!!$ ip = idxin(i) +!!$ call psb_hash_searchkey(ip,lip,idxmap%hash,info) +!!$ if (lip > 0) idxout(i) = lip + idxmap%local_rows +!!$ else +!!$ idxout(i) = -1 +!!$ end if +!!$ end do +!!$ else +!!$! !$ write(0,*) 'Block status: invalid ',idxmap%get_state() +!!$ idxout(1:im) = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ end if +!!$ +!!$ if (is > im) info = -3 +!!$ +!!$ end subroutine block_g2lv2 - subroutine block_g2ls1(idx,idxmap,info,mask,owned) + subroutine block_lg2ls1(idx,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - integer(psb_ipk_) :: idxv(1) + integer(psb_lpk_) :: idxv(1) info = 0 if (present(mask)) then @@ -308,34 +750,43 @@ contains call idxmap%g2lip(idxv,info,owned=owned) idx = idxv(1) - end subroutine block_g2ls1 + end subroutine block_lg2ls1 - subroutine block_g2ls2(idxin,idxout,idxmap,info,mask,owned) + subroutine block_lg2ls2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_gen_block_map), intent(in) :: idxmap - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - idxout = idxin - call idxmap%g2lip(idxout,info,mask,owned) + integer(psb_lpk_) :: idxv(1) + info = 0 + + if (present(mask)) then + if (.not.mask) return + end if - end subroutine block_g2ls2 + idxv(1) = idxin + call idxmap%g2lip(idxv,info,owned=owned) + idxout = idxv(1) + + end subroutine block_lg2ls2 - subroutine block_g2lv1(idx,idxmap,info,mask,owned) + subroutine block_lg2lv1(idx,idxmap,info,mask,owned) use psb_penv_mod use psb_sort_mod implicit none class(psb_gen_block_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: i, nv, is, ip, lip - integer(psb_mpik_) :: ictxt, iam, np + integer(psb_ipk_) :: i, nv, is + integer(psb_lpk_) :: tidx, ip, lip + integer(psb_mpk_) :: ictxt, iam, np logical :: owned_ info = 0 @@ -344,7 +795,7 @@ contains if (present(mask)) then if (size(mask) < size(idx)) then -!!$ write(0,*) 'Block g2l: size of mask', size(mask),size(idx) + !write(0,*) 'Block g2l: size of mask', size(mask),size(idx) info = -1 return end if @@ -361,12 +812,14 @@ contains if (idxmap%is_asb()) then do i=1, is if (mask(i)) then - if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idx(i)).and. & + & (idx(i) <= idxmap%max_glob_row)) then idx(i) = idx(i) - idxmap%min_glob_row + 1 else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then nv = size(idxmap%srt_l2g,1) - idx(i) = psb_ibsrch(idx(i),nv,idxmap%srt_l2g(:,1)) + tidx = idx(i) + idx(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) if (idx(i) > 0) idx(i) = idxmap%srt_l2g(idx(i),2)+idxmap%local_rows else idx(i) = -1 @@ -376,7 +829,8 @@ contains else if (idxmap%is_valid()) then do i=1,is if (mask(i)) then - if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idx(i)).and.& + & (idx(i) <= idxmap%max_glob_row)) then idx(i) = idx(i) - idxmap%min_glob_row + 1 else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then @@ -398,12 +852,14 @@ contains if (idxmap%is_asb()) then do i=1, is - if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idx(i)).and.& + & (idx(i) <= idxmap%max_glob_row)) then idx(i) = idx(i) - idxmap%min_glob_row + 1 else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then nv = size(idxmap%srt_l2g,1) - idx(i) = psb_ibsrch(idx(i),nv,idxmap%srt_l2g(:,1)) + tidx = idx(i) + idx(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) if (idx(i) > 0) idx(i) = idxmap%srt_l2g(idx(i),2)+idxmap%local_rows else idx(i) = -1 @@ -412,7 +868,8 @@ contains else if (idxmap%is_valid()) then do i=1,is - if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idx(i)).and.& + & (idx(i) <= idxmap%max_glob_row)) then idx(i) = idx(i) - idxmap%min_glob_row + 1 else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then @@ -424,28 +881,28 @@ contains end if end do else -!!$ write(0,*) 'Block status: invalid ',idxmap%get_state() idx(1:is) = -1 info = -1 end if end if - end subroutine block_g2lv1 + end subroutine block_lg2lv1 - subroutine block_g2lv2(idxin,idxout,idxmap,info,mask,owned) + subroutine block_lg2lv2(idxin,idxout,idxmap,info,mask,owned) use psb_penv_mod use psb_sort_mod implicit none class(psb_gen_block_map), intent(in) :: idxmap - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: i, nv, is, ip, lip, im - integer(psb_mpik_) :: ictxt, iam, np + integer(psb_ipk_) :: i, nv, is, im + integer(psb_lpk_) :: tidx, ip, lip + integer(psb_mpk_) :: ictxt, iam, np logical :: owned_ info = 0 @@ -472,13 +929,16 @@ contains if (idxmap%is_asb()) then do i=1, im if (mask(i)) then - if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idxin(i)).and.& + & (idxin(i) <= idxmap%max_glob_row)) then idxout(i) = idxin(i) - idxmap%min_glob_row + 1 else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then nv = size(idxmap%srt_l2g,1) - idxout(i) = psb_ibsrch(idxin(i),nv,idxmap%srt_l2g(:,1)) - if (idxout(i) > 0) idxout(i) = idxmap%srt_l2g(idxout(i),2)+idxmap%local_rows + tidx = idxin(i) + idxout(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) + if (idxout(i) > 0) & + & idxout(i) = idxmap%srt_l2g(idxout(i),2)+idxmap%local_rows else idxout(i) = -1 end if @@ -487,7 +947,8 @@ contains else if (idxmap%is_valid()) then do i=1,im if (mask(i)) then - if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idxin(i)).and.& + & (idxin(i) <= idxmap%max_glob_row)) then idxout(i) = idxin(i) - idxmap%min_glob_row + 1 else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then @@ -509,13 +970,16 @@ contains if (idxmap%is_asb()) then do i=1, im - if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idxin(i)).and.& + & (idxin(i) <= idxmap%max_glob_row)) then idxout(i) = idxin(i) - idxmap%min_glob_row + 1 else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then nv = size(idxmap%srt_l2g,1) - idxout(i) = psb_ibsrch(idxin(i),nv,idxmap%srt_l2g(:,1)) - if (idxout(i) > 0) idxout(i) = idxmap%srt_l2g(idxout(i),2)+idxmap%local_rows + tidx = idxin(i) + idxout(i) = psb_bsrch(tidx,nv,idxmap%srt_l2g(:,1)) + if (idxout(i) > 0) & + & idxout(i) = idxmap%srt_l2g(idxout(i),2)+idxmap%local_rows else idxout(i) = -1 end if @@ -523,7 +987,8 @@ contains else if (idxmap%is_valid()) then do i=1,im - if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idxin(i)).and.& + & (idxin(i) <= idxmap%max_glob_row)) then idxout(i) = idxin(i) - idxmap%min_glob_row + 1 else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)& &.and.(.not.owned_)) then @@ -544,21 +1009,463 @@ contains if (is > im) info = -3 - end subroutine block_g2lv2 + end subroutine block_lg2lv2 +!!$ subroutine block_g2ls1_ins(idx,idxmap,info,mask, lidx) +!!$ use psb_realloc_mod +!!$ use psb_sort_mod +!!$ implicit none +!!$ class(psb_gen_block_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ integer(psb_ipk_), intent(in), optional :: lidx +!!$ +!!$ integer(psb_ipk_) :: idxv(1), lidxv(1) +!!$ +!!$ info = 0 +!!$ if (present(mask)) then +!!$ if (.not.mask) return +!!$ end if +!!$ idxv(1) = idx +!!$ if (present(lidx)) then +!!$ lidxv(1) = lidx +!!$ call idxmap%g2lip_ins(idxv,info,lidx=lidxv) +!!$ else +!!$ call idxmap%g2lip_ins(idxv,info) +!!$ end if +!!$ idx = idxv(1) +!!$ +!!$ end subroutine block_g2ls1_ins +!!$ +!!$ subroutine block_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) +!!$ implicit none +!!$ class(psb_gen_block_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin +!!$ integer(psb_ipk_), intent(out) :: idxout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ integer(psb_ipk_), intent(in), optional :: lidx +!!$ +!!$ idxout = idxin +!!$ call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) +!!$ +!!$ end subroutine block_g2ls2_ins +!!$ +!!$ +!!$ subroutine block_g2lv1_ins(idx,idxmap,info,mask,lidx) +!!$ use psb_realloc_mod +!!$ use psb_sort_mod +!!$ implicit none +!!$ class(psb_gen_block_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ integer(psb_ipk_), intent(in), optional :: lidx(:) +!!$ +!!$ integer(psb_ipk_) :: i, nv, is, ix +!!$ integer(psb_ipk_) :: ip, lip, nxt +!!$ +!!$ +!!$ info = 0 +!!$ is = size(idx) +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < size(idx)) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(lidx)) then +!!$ if (size(lidx) < size(idx)) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ +!!$ +!!$ if (idxmap%is_asb()) then +!!$ ! State is wrong for this one ! +!!$ idx = -1 +!!$ info = -1 +!!$ +!!$ else if (idxmap%is_valid()) then +!!$ +!!$ if (present(lidx)) then +!!$ if (present(mask)) then +!!$ +!!$ do i=1, is +!!$ if (mask(i)) then +!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then +!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ +!!$ if (lidx(i) <= idxmap%local_rows) then +!!$ info = -5 +!!$ return +!!$ end if +!!$ nxt = lidx(i)-idxmap%local_rows +!!$ ip = idx(i) +!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) +!!$ if (info >= 0) then +!!$ if (lip == nxt) then +!!$ ! We have added one item +!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = max(lidx(i),idxmap%local_cols) +!!$ idxmap%loc_to_glob(nxt) = idx(i) +!!$ end if +!!$ info = psb_success_ +!!$ else +!!$ info = -5 +!!$ return +!!$ end if +!!$ idx(i) = lip + idxmap%local_rows +!!$ else +!!$ idx(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, is +!!$ +!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then +!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ if (lidx(i) <= idxmap%local_rows) then +!!$ info = -5 +!!$ return +!!$ end if +!!$ nxt = lidx(i)-idxmap%local_rows +!!$ ip = idx(i) +!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) +!!$ +!!$ if (info >= 0) then +!!$ if (lip == nxt) then +!!$ ! We have added one item +!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = max(lidx(i),idxmap%local_cols) +!!$ idxmap%loc_to_glob(nxt) = idx(i) +!!$ end if +!!$ info = psb_success_ +!!$ else +!!$ info = -5 +!!$ return +!!$ end if +!!$ idx(i) = lip + idxmap%local_rows +!!$ else +!!$ idx(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end do +!!$ end if +!!$ +!!$ else if (.not.present(lidx)) then +!!$ +!!$ if (present(mask)) then +!!$ do i=1, is +!!$ if (mask(i)) then +!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then +!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ nv = idxmap%local_cols-idxmap%local_rows +!!$ nxt = nv + 1 +!!$ ip = idx(i) +!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) +!!$ if (info >= 0) then +!!$ if (lip == nxt) then +!!$ ! We have added one item +!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = nxt + idxmap%local_rows +!!$ idxmap%loc_to_glob(nxt) = idx(i) +!!$ end if +!!$ info = psb_success_ +!!$ else +!!$ info = -5 +!!$ return +!!$ end if +!!$ idx(i) = lip + idxmap%local_rows +!!$ else +!!$ idx(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, is +!!$ +!!$ if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then +!!$ idx(i) = idx(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ nv = idxmap%local_cols-idxmap%local_rows +!!$ nxt = nv + 1 +!!$ ip = idx(i) +!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) +!!$ +!!$ if (info >= 0) then +!!$ if (lip == nxt) then +!!$ ! We have added one item +!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = nxt + idxmap%local_rows +!!$ idxmap%loc_to_glob(nxt) = idx(i) +!!$ end if +!!$ info = psb_success_ +!!$ else +!!$ info = -5 +!!$ return +!!$ end if +!!$ idx(i) = lip + idxmap%local_rows +!!$ else +!!$ idx(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end do +!!$ end if +!!$ end if +!!$ +!!$ else +!!$ idx = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ end subroutine block_g2lv1_ins +!!$ +!!$ subroutine block_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) +!!$ use psb_realloc_mod +!!$ use psb_sort_mod +!!$ implicit none +!!$ class(psb_gen_block_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin(:) +!!$ integer(psb_ipk_), intent(out) :: idxout(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ integer(psb_ipk_), intent(in), optional :: lidx(:) +!!$ +!!$ integer(psb_ipk_) :: i, nv, is, ix, im +!!$ integer(psb_ipk_) :: ip, lip, nxt +!!$ +!!$ +!!$ info = 0 +!!$ +!!$ is = size(idxin) +!!$ im = min(is,size(idxout)) +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < im) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(lidx)) then +!!$ if (size(lidx) < im) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ +!!$ if (idxmap%is_asb()) then +!!$ ! State is wrong for this one ! +!!$ idxout = -1 +!!$ info = -1 +!!$ +!!$ else if (idxmap%is_valid()) then +!!$ +!!$ if (present(lidx)) then +!!$ if (present(mask)) then +!!$ +!!$ do i=1, im +!!$ if (mask(i)) then +!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then +!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then +!!$ +!!$ if (lidx(i) <= idxmap%local_rows) then +!!$ info = -5 +!!$ return +!!$ end if +!!$ nxt = lidx(i)-idxmap%local_rows +!!$ ip = idxin(i) +!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) +!!$ if (info >= 0) then +!!$ if (lip == nxt) then +!!$ ! We have added one item +!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = max(lidx(i),idxmap%local_cols) +!!$ idxmap%loc_to_glob(nxt) = idxin(i) +!!$ end if +!!$ info = psb_success_ +!!$ else +!!$ info = -5 +!!$ return +!!$ end if +!!$ idxout(i) = lip + idxmap%local_rows +!!$ else +!!$ idxout(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, im +!!$ +!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then +!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then +!!$ if (lidx(i) <= idxmap%local_rows) then +!!$ info = -5 +!!$ return +!!$ end if +!!$ nxt = lidx(i)-idxmap%local_rows +!!$ ip = idxin(i) +!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) +!!$ +!!$ if (info >= 0) then +!!$ if (lip == nxt) then +!!$ ! We have added one item +!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = max(lidx(i),idxmap%local_cols) +!!$ idxmap%loc_to_glob(nxt) = idxin(i) +!!$ end if +!!$ info = psb_success_ +!!$ else +!!$ info = -5 +!!$ return +!!$ end if +!!$ idxout(i) = lip + idxmap%local_rows +!!$ else +!!$ idxout(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end do +!!$ end if +!!$ +!!$ else if (.not.present(lidx)) then +!!$ +!!$ if (present(mask)) then +!!$ do i=1, im +!!$ if (mask(i)) then +!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then +!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then +!!$ nv = idxmap%local_cols-idxmap%local_rows +!!$ nxt = nv + 1 +!!$ ip = idxin(i) +!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) +!!$ if (info >= 0) then +!!$ if (lip == nxt) then +!!$ ! We have added one item +!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = nxt + idxmap%local_rows +!!$ idxmap%loc_to_glob(nxt) = idxin(i) +!!$ end if +!!$ info = psb_success_ +!!$ else +!!$ info = -5 +!!$ return +!!$ end if +!!$ idxout(i) = lip + idxmap%local_rows +!!$ else +!!$ idxout(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, im +!!$ +!!$ if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then +!!$ idxout(i) = idxin(i) - idxmap%min_glob_row + 1 +!!$ else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then +!!$ nv = idxmap%local_cols-idxmap%local_rows +!!$ nxt = nv + 1 +!!$ ip = idxin(i) +!!$ call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) +!!$ +!!$ if (info >= 0) then +!!$ if (lip == nxt) then +!!$ ! We have added one item +!!$ call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = nxt + idxmap%local_rows +!!$ idxmap%loc_to_glob(nxt) = idxin(i) +!!$ end if +!!$ info = psb_success_ +!!$ else +!!$ info = -5 +!!$ return +!!$ end if +!!$ idxout(i) = lip + idxmap%local_rows +!!$ else +!!$ idxout(i) = -1 +!!$ info = -1 +!!$ end if +!!$ end do +!!$ end if +!!$ end if +!!$ +!!$ else +!!$ idxout = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ if (is > im) then +!!$! !$ write(0,*) 'g2lv2_ins err -3' +!!$ info = -3 +!!$ end if +!!$ +!!$ end subroutine block_g2lv2_ins - - subroutine block_g2ls1_ins(idx,idxmap,info,mask, lidx) + subroutine block_lg2ls1_ins(idx,idxmap,info,mask, lidx) use psb_realloc_mod use psb_sort_mod implicit none class(psb_gen_block_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx - integer(psb_ipk_) :: idxv(1), lidxv(1) + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) info = 0 if (present(mask)) then @@ -573,35 +1480,36 @@ contains end if idx = idxv(1) - end subroutine block_g2ls1_ins + end subroutine block_lg2ls1_ins - subroutine block_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) + subroutine block_lg2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) implicit none class(psb_gen_block_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx - - idxout = idxin - call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) - - end subroutine block_g2ls2_ins + integer(psb_lpk_) :: tidx + tidx = idxin + call idxmap%g2lip_ins(tidx,info,mask=mask,lidx=lidx) + idxout = tidx + end subroutine block_lg2ls2_ins - subroutine block_g2lv1_ins(idx,idxmap,info,mask,lidx) + subroutine block_lg2lv1_ins(idx,idxmap,info,mask,lidx) use psb_realloc_mod use psb_sort_mod implicit none class(psb_gen_block_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_) :: i, nv, is, ix - integer(psb_ipk_) :: ip, lip, nxt + integer(psb_lpk_) :: ip, lip, lnxt + integer(psb_ipk_) :: nxt info = 0 @@ -633,7 +1541,8 @@ contains do i=1, is if (mask(i)) then - if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idx(i)).and.& + & (idx(i) <= idxmap%max_glob_row)) then idx(i) = idx(i) - idxmap%min_glob_row + 1 else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then @@ -641,9 +1550,10 @@ contains info = -5 return end if - nxt = lidx(i)-idxmap%local_rows - ip = idx(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + lnxt = lidx(i)-idxmap%local_rows + ip = idx(i) + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then if (lip == nxt) then ! We have added one item @@ -672,17 +1582,18 @@ contains do i=1, is - if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idx(i)).and.& + & (idx(i) <= idxmap%max_glob_row)) then idx(i) = idx(i) - idxmap%min_glob_row + 1 else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then if (lidx(i) <= idxmap%local_rows) then info = -5 return end if - nxt = lidx(i)-idxmap%local_rows + lnxt = lidx(i)-idxmap%local_rows ip = idx(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) - + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then if (lip == nxt) then ! We have added one item @@ -712,13 +1623,15 @@ contains if (present(mask)) then do i=1, is if (mask(i)) then - if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idx(i)).and.& + & (idx(i) <= idxmap%max_glob_row)) then idx(i) = idx(i) - idxmap%min_glob_row + 1 else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then - nv = idxmap%local_cols-idxmap%local_rows - nxt = nv + 1 - ip = idx(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + nv = idxmap%local_cols-idxmap%local_rows + lnxt = nv + 1 + ip = idx(i) + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then if (lip == nxt) then ! We have added one item @@ -747,14 +1660,15 @@ contains do i=1, is - if ((idxmap%min_glob_row <= idx(i)).and.(idx(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idx(i)).and.& + & (idx(i) <= idxmap%max_glob_row)) then idx(i) = idx(i) - idxmap%min_glob_row + 1 else if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then - nv = idxmap%local_cols-idxmap%local_rows - nxt = nv + 1 - ip = idx(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) - + nv = idxmap%local_cols-idxmap%local_rows + lnxt = nv + 1 + ip = idx(i) + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then if (lip == nxt) then ! We have added one item @@ -785,25 +1699,26 @@ contains info = -1 end if - end subroutine block_g2lv1_ins + end subroutine block_lg2lv1_ins - subroutine block_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) + subroutine block_lg2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) use psb_realloc_mod use psb_sort_mod implicit none class(psb_gen_block_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) integer(psb_ipk_) :: i, nv, is, ix, im - integer(psb_ipk_) :: ip, lip, nxt + integer(psb_lpk_) :: ip, lip, lnxt + integer(psb_ipk_) :: nxt info = 0 - + is = size(idxin) im = min(is,size(idxout)) @@ -832,7 +1747,8 @@ contains do i=1, im if (mask(i)) then - if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idxin(i)).and.& + & (idxin(i) <= idxmap%max_glob_row)) then idxout(i) = idxin(i) - idxmap%min_glob_row + 1 else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then @@ -840,11 +1756,12 @@ contains info = -5 return end if - nxt = lidx(i)-idxmap%local_rows + lnxt = lidx(i)-idxmap%local_rows ip = idxin(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then - if (lip == nxt) then + if (lip == nxt) then ! We have added one item call psb_ensure_size(nxt,idxmap%loc_to_glob,info,addsz=laddsz) if (info /= 0) then @@ -871,17 +1788,18 @@ contains do i=1, im - if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idxin(i)).and.& + & (idxin(i) <= idxmap%max_glob_row)) then idxout(i) = idxin(i) - idxmap%min_glob_row + 1 else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then if (lidx(i) <= idxmap%local_rows) then info = -5 return end if - nxt = lidx(i)-idxmap%local_rows + lnxt = lidx(i)-idxmap%local_rows ip = idxin(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) - + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then if (lip == nxt) then ! We have added one item @@ -911,13 +1829,15 @@ contains if (present(mask)) then do i=1, im if (mask(i)) then - if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idxin(i)).and.& + & (idxin(i) <= idxmap%max_glob_row)) then idxout(i) = idxin(i) - idxmap%min_glob_row + 1 else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then nv = idxmap%local_cols-idxmap%local_rows - nxt = nv + 1 + lnxt = nv + 1 ip = idxin(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then if (lip == nxt) then ! We have added one item @@ -946,14 +1866,15 @@ contains do i=1, im - if ((idxmap%min_glob_row <= idxin(i)).and.(idxin(i) <= idxmap%max_glob_row)) then + if ((idxmap%min_glob_row <= idxin(i)).and.& + & (idxin(i) <= idxmap%max_glob_row)) then idxout(i) = idxin(i) - idxmap%min_glob_row + 1 else if ((1<= idxin(i)).and.(idxin(i) <= idxmap%global_rows)) then nv = idxmap%local_cols-idxmap%local_rows - nxt = nv + 1 + lnxt = nv + 1 ip = idxin(i) - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) - + call psb_hash_searchinskey(ip,lip,lnxt,idxmap%hash,info) + nxt = lnxt if (info >= 0) then if (lip == nxt) then ! We have added one item @@ -985,31 +1906,31 @@ contains end if if (is > im) then -!!$ write(0,*) 'g2lv2_ins err -3' info = -3 end if - end subroutine block_g2lv2_ins + end subroutine block_lg2lv2_ins subroutine block_fnd_owner(idx,iprc,idxmap,info) use psb_penv_mod implicit none - integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_gen_block_map), intent(in) :: idxmap integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: ictxt, iam, np, nv, ip, i + integer(psb_lpk_) :: tidx ictxt = idxmap%get_ctxt() call psb_info(ictxt,iam,np) nv = size(idx) allocate(iprc(nv),stat=info) if (info /= 0) then -!!$ write(0,*) 'Memory allocation failure in repl_map_fnd-owner' return end if - do i=1, nv - ip = gen_block_search(idx(i)-1,np+1,idxmap%vnl) + do i=1, nv + tidx = idx(i) + ip = gen_block_search(tidx-1,np+1,idxmap%vnl) iprc(i) = ip - 1 end do @@ -1023,13 +1944,14 @@ contains use psb_error_mod implicit none class(psb_gen_block_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: nl integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_mpik_) :: iam, np - integer(psb_ipk_) :: i, ntot - integer(psb_ipk_), allocatable :: vnl(:) + integer(psb_mpk_) :: iam, np + integer(psb_ipk_) :: i + integer(psb_lpk_) :: ntot + integer(psb_lpk_), allocatable :: vnl(:) info = 0 call psb_info(ictxt,iam,np) @@ -1087,9 +2009,9 @@ contains class(psb_gen_block_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: nhal - integer(psb_mpik_) :: ictxt, iam, np - + integer(psb_ipk_) :: nhal, i + integer(psb_mpk_) :: ictxt, iam, np + logical :: debug=.false. info = 0 ictxt = idxmap%get_ctxt() call psb_info(ictxt,iam,np) @@ -1102,7 +2024,12 @@ contains call psb_msort(idxmap%srt_l2g(:,1),& & ix=idxmap%srt_l2g(:,2),dir=psb_sort_up_) - + if (debug) then + do i=1, nhal + write(0,*) iam,' block_l2g:',idxmap%srt_l2g(i,1:2) + end do + end if + call psb_free(idxmap%hash,info) call idxmap%set_state(psb_desc_asb_) end subroutine block_asb @@ -1185,7 +2112,8 @@ contains class(psb_gen_block_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act, nr,nc,k, nl, ictxt - integer(psb_ipk_), allocatable :: idx(:),lidx(:) + integer(psb_ipk_), allocatable :: lidx(:) + integer(psb_lpk_), allocatable :: idx(:) character(len=20) :: name='block_reinit' logical, parameter :: debug=.false. @@ -1226,14 +2154,14 @@ contains return end subroutine block_reinit - ! ! This is a purely internal version of "binary" search ! specialized for gen_block usage. ! function gen_block_search(key,n,v) result(ipos) implicit none - integer(psb_ipk_) :: ipos, key, n + integer(psb_lpk_) :: key + integer(psb_ipk_) :: ipos, n integer(psb_ipk_) :: v(:) integer(psb_ipk_) :: lb, ub, m @@ -1271,4 +2199,45 @@ contains return end function gen_block_search + function l_gen_block_search(key,n,v) result(ipos) + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_lpk_) :: key + integer(psb_lpk_) :: v(:) + + integer(psb_ipk_) :: lb, ub, m + + if (n < 5) then + ! don't bother with binary search for very + ! small vectors + ipos = 0 + do + if (ipos == n) return + if (key < v(ipos+1)) return + ipos = ipos + 1 + end do + else + lb = 1 + ub = n + ipos = -1 + + do while (lb <= ub) + m = (lb+ub)/2 + if (key==v(m)) then + ipos = m + return + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + if (v(ub) > key) then + ub = ub - 1 + end if + ipos = ub + endif + return + end function l_gen_block_search + end module psb_gen_block_map_mod diff --git a/base/modules/desc/psb_glist_map_mod.f90 b/base/modules/desc/psb_glist_map_mod.f90 index 4097ae3cf..4dc60b511 100644 --- a/base/modules/desc/psb_glist_map_mod.f90 +++ b/base/modules/desc/psb_glist_map_mod.f90 @@ -67,12 +67,12 @@ contains function glist_sizeof(idxmap) result(val) implicit none class(psb_glist_map), intent(in) :: idxmap - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = idxmap%psb_list_map%sizeof() if (allocated(idxmap%vgp)) & - & val = val + size(idxmap%vgp)*psb_sizeof_int + & val = val + size(idxmap%vgp)*psb_sizeof_ip end function glist_sizeof @@ -96,12 +96,13 @@ contains use psb_error_mod implicit none class(psb_glist_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: vg(:) integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_mpik_) :: iam, np - integer(psb_ipk_) :: i, n, nl + integer(psb_mpk_) :: iam, np + integer(psb_ipk_) :: nl + integer(psb_lpk_) :: i, n info = 0 @@ -153,12 +154,12 @@ contains use psb_penv_mod use psb_sort_mod implicit none - integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_glist_map), intent(in) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_mpik_) :: ictxt, iam, np - integer(psb_ipk_) :: nv, i, ngp + integer(psb_mpk_) :: ictxt, iam, np + integer(psb_lpk_) :: nv, i, ngp ictxt = idxmap%get_ctxt() call psb_info(ictxt,iam,np) diff --git a/base/modules/desc/psb_hash_map_mod.f90 b/base/modules/desc/psb_hash_map_mod.f90 index 538441ede..0e14384ed 100644 --- a/base/modules/desc/psb_hash_map_mod.f90 +++ b/base/modules/desc/psb_hash_map_mod.f90 @@ -60,8 +60,9 @@ module psb_hash_map_mod type, extends(psb_indx_map) :: psb_hash_map - integer(psb_ipk_) :: hashvsize, hashvmask - integer(psb_ipk_), allocatable :: hashv(:), glb_lc(:,:), loc_to_glob(:) + integer(psb_lpk_) :: hashvsize, hashvmask + integer(psb_ipk_), allocatable :: hashv(:) + integer(psb_lpk_), allocatable :: glb_lc(:,:), loc_to_glob(:) type(psb_hash_type) :: hash contains @@ -78,20 +79,20 @@ module psb_hash_map_mod procedure, nopass :: row_extendable => hash_row_extendable - procedure, pass(idxmap) :: l2gs1 => hash_l2gs1 - procedure, pass(idxmap) :: l2gs2 => hash_l2gs2 - procedure, pass(idxmap) :: l2gv1 => hash_l2gv1 - procedure, pass(idxmap) :: l2gv2 => hash_l2gv2 + procedure, pass(idxmap) :: ll2gs1 => hash_l2gs1 + procedure, pass(idxmap) :: ll2gs2 => hash_l2gs2 + procedure, pass(idxmap) :: ll2gv1 => hash_l2gv1 + procedure, pass(idxmap) :: ll2gv2 => hash_l2gv2 - procedure, pass(idxmap) :: g2ls1 => hash_g2ls1 - procedure, pass(idxmap) :: g2ls2 => hash_g2ls2 - procedure, pass(idxmap) :: g2lv1 => hash_g2lv1 - procedure, pass(idxmap) :: g2lv2 => hash_g2lv2 + procedure, pass(idxmap) :: lg2ls1 => hash_g2ls1 + procedure, pass(idxmap) :: lg2ls2 => hash_g2ls2 + procedure, pass(idxmap) :: lg2lv1 => hash_g2lv1 + procedure, pass(idxmap) :: lg2lv2 => hash_g2lv2 - procedure, pass(idxmap) :: g2ls1_ins => hash_g2ls1_ins - procedure, pass(idxmap) :: g2ls2_ins => hash_g2ls2_ins - procedure, pass(idxmap) :: g2lv1_ins => hash_g2lv1_ins - procedure, pass(idxmap) :: g2lv2_ins => hash_g2lv2_ins + procedure, pass(idxmap) :: lg2ls1_ins => hash_g2ls1_ins + procedure, pass(idxmap) :: lg2ls2_ins => hash_g2ls2_ins + procedure, pass(idxmap) :: lg2lv1_ins => hash_g2lv1_ins + procedure, pass(idxmap) :: lg2lv2_ins => hash_g2lv2_ins procedure, pass(idxmap) :: hash_cpy generic, public :: assignment(=) => hash_cpy @@ -104,14 +105,14 @@ module psb_hash_map_mod & hash_l2gv1, hash_l2gv2, hash_g2ls1, hash_g2ls2, & & hash_g2lv1, hash_g2lv2, hash_g2ls1_ins, hash_g2ls2_ins, & & hash_g2lv1_ins, hash_g2lv2_ins, hash_init_vlu, & - & hash_bld_g2l_map, hash_inner_cnvs1, hash_inner_cnvs2,& - & hash_inner_cnv1, hash_inner_cnv2, hash_row_extendable + & hash_bld_g2l_map, hash_inner_cnvs2, hash_inner_cnvs1, & + & hash_inner_cnv2, hash_inner_cnv1, hash_row_extendable integer(psb_ipk_), private :: laddsz=500 interface hash_inner_cnv - module procedure hash_inner_cnvs1, hash_inner_cnvs2,& - & hash_inner_cnv1, hash_inner_cnv2 + module procedure hash_inner_cnvs2, hash_inner_cnv2,& + & hash_inner_cnvs1, hash_inner_cnv1 end interface hash_inner_cnv private :: hash_inner_cnv @@ -126,16 +127,16 @@ contains function hash_sizeof(idxmap) result(val) implicit none class(psb_hash_map), intent(in) :: idxmap - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = idxmap%psb_indx_map%sizeof() - val = val + 2 * psb_sizeof_int + val = val + 2 * psb_sizeof_ip if (allocated(idxmap%hashv)) & - & val = val + size(idxmap%hashv)*psb_sizeof_int + & val = val + size(idxmap%hashv)*psb_sizeof_ip if (allocated(idxmap%glb_lc)) & - & val = val + size(idxmap%glb_lc)*psb_sizeof_int + & val = val + size(idxmap%glb_lc)*psb_sizeof_lp if (allocated(idxmap%loc_to_glob)) & - & val = val + size(idxmap%loc_to_glob)*psb_sizeof_int + & val = val + size(idxmap%loc_to_glob)*psb_sizeof_lp val = val + psb_sizeof(idxmap%hash) end function hash_sizeof @@ -159,11 +160,11 @@ contains subroutine hash_l2gs1(idx,idxmap,info,mask,owned) implicit none class(psb_hash_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - integer(psb_ipk_) :: idxv(1) + integer(psb_lpk_) :: idxv(1) info = 0 if (present(mask)) then if (.not.mask) return @@ -179,13 +180,21 @@ contains implicit none class(psb_hash_map), intent(in) :: idxmap integer(psb_ipk_), intent(in) :: idxin - integer(psb_ipk_), intent(out) :: idxout + integer(psb_lpk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - idxout = idxin - call idxmap%l2gip(idxout,info,mask,owned) + integer(psb_lpk_) :: idxv(1) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idxin + call idxmap%l2gip(idxv,info,owned=owned) + idxout = idxv(1) + end subroutine hash_l2gs2 @@ -193,7 +202,7 @@ contains subroutine hash_l2gv1(idx,idxmap,info,mask,owned) implicit none class(psb_hash_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned @@ -249,7 +258,7 @@ contains implicit none class(psb_hash_map), intent(in) :: idxmap integer(psb_ipk_), intent(in) :: idxin(:) - integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_lpk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned @@ -270,11 +279,11 @@ contains subroutine hash_g2ls1(idx,idxmap,info,mask,owned) implicit none class(psb_hash_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - integer(psb_ipk_) :: idxv(1) + integer(psb_lpk_) :: idxv(1) info = 0 if (present(mask)) then @@ -290,14 +299,21 @@ contains subroutine hash_g2ls2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_hash_map), intent(in) :: idxmap - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned + integer(psb_lpk_) :: idxv(1) + info = 0 - idxout = idxin - call idxmap%g2lip(idxout,info,mask,owned) + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idxin + call idxmap%g2lip(idxv,info,owned=owned) + idxout = idxv(1) end subroutine hash_g2ls2 @@ -307,12 +323,13 @@ contains use psb_sort_mod implicit none class(psb_hash_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: i, is, mglob, ip, lip, nrow, ncol, nrm - integer(psb_mpik_) :: ictxt, iam, np + integer(psb_ipk_) :: i, lip, nrow, nrm, is + integer(psb_lpk_) :: ncol, ip, tlip, mglob + integer(psb_mpk_) :: ictxt, iam, np logical :: owned_ info = 0 @@ -357,9 +374,12 @@ contains idx(i) = -1 cycle endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm) - if (lip < 0) & - & call psb_hash_searchkey(ip,lip,idxmap%hash,info) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,nrm) + if (lip < 0) then + call psb_hash_searchkey(ip,tlip,idxmap%hash,info) + lip = tlip + end if if (owned_) then if (lip<=nrow) then idx(i) = lip @@ -393,9 +413,12 @@ contains idx(i) = -1 cycle endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,nrm) - if (lip < 0) & - & call psb_hash_searchkey(ip,lip,idxmap%hash,info) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,nrm) + if (lip < 0) then + call psb_hash_searchkey(ip,tlip,idxmap%hash,info) + lip = tlip + end if if (owned_) then if (lip<=nrow) then idx(i) = lip @@ -419,20 +442,23 @@ contains end subroutine hash_g2lv1 subroutine hash_g2lv2(idxin,idxout,idxmap,info,mask,owned) + use psb_realloc_mod implicit none class(psb_hash_map), intent(in) :: idxmap - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned integer(psb_ipk_) :: is, im - + integer(psb_lpk_), allocatable :: tidx(:) is = size(idxin) im = min(is,size(idxout)) - idxout(1:im) = idxin(1:im) - call idxmap%g2lip(idxout(1:im),info,mask,owned) + call psb_realloc(im,tidx,info) + tidx(1:im) = idxin(1:im) + call idxmap%g2lip(tidx(1:im),info,mask,owned) + idxout(1:im) = tidx(1:im) if (is > im) then write(0,*) 'g2lv2 err -3' info = -3 @@ -447,12 +473,13 @@ contains use psb_sort_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx - integer(psb_ipk_) :: idxv(1), lidxv(1) + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) info = 0 if (present(mask)) then @@ -473,15 +500,28 @@ contains subroutine hash_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) - idxout = idxin - call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idxin + if (present(lidx)) then + lidxv(1) = lidx + call idxmap%g2lip_ins(idxv,info,lidx=lidxv) + else + call idxmap%g2lip_ins(idxv,info) + end if + idxout = idxv(1) end subroutine hash_g2ls2_ins @@ -493,13 +533,14 @@ contains use psb_penv_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) - integer(psb_ipk_) :: i, is, mglob, ip, lip, nrow, ncol, & - & nxt, err_act + integer(psb_ipk_) :: i, is, lip, nrow, ncol, & + & err_act + integer(psb_lpk_) :: mglob, ip, nxt, tlip integer(psb_ipk_) :: ictxt, me, np character(len=20) :: name,ch_err @@ -540,23 +581,24 @@ contains idx(i) = -1 cycle endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) then + call hash_inner_cnv(ip,lip,idxmap%hashvmask,& + & idxmap%hashv,idxmap%glb_lc,ncol) + if (lip < 0) then + tlip = lip nxt = lidx(i) if (nxt <= nrow) then idx(i) = -1 cycle endif - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) if (info >=0) then - if (nxt == lip) then + if (nxt == tlip) then ncol = max(ncol,nxt) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then - info=1 - ch_err='psb_ensure_size' call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + &a_err='psb_ensure_size',i_err=(/info/)) goto 9999 end if idxmap%loc_to_glob(nxt) = ip @@ -564,9 +606,8 @@ contains endif info = psb_success_ else - ch_err='SearchInsKeyVal' call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + & a_err='SearchInsKeyVal',i_err=(/info/)) goto 9999 end if end if @@ -586,25 +627,25 @@ contains idx(i) = -1 cycle endif - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) if (lip < 0) then nxt = lidx(i) if (nxt <= nrow) then idx(i) = -1 cycle endif - call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) - + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + if (info >=0) then if (nxt == lip) then ncol = max(nxt,ncol) - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& - & pad=-ione,addsz=laddsz) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then info=1 - ch_err='psb_ensure_size' call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + &a_err='psb_ensure_size',i_err=(/info/)) goto 9999 end if idxmap%loc_to_glob(nxt) = ip @@ -612,9 +653,8 @@ contains endif info = psb_success_ else - ch_err='SearchInsKeyVal' call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + & a_err='SearchInsKeyVal',i_err=(/info/)) goto 9999 end if end if @@ -636,19 +676,22 @@ contains cycle endif nxt = ncol + 1 - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) & - & call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + end if if (info >=0) then if (nxt == lip) then ncol = nxt - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then info=1 - ch_err='psb_ensure_size' call psb_errpush(psb_err_from_subroutine_ai_,name,& - &a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + & a_err='psb_ensure_size',i_err=(/info/)) goto 9999 end if idxmap%loc_to_glob(nxt) = ip @@ -656,9 +699,8 @@ contains endif info = psb_success_ else - ch_err='SearchInsKeyVal' call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err=ch_err,i_err=(/info,izero,izero,izero,izero/)) + & a_err='SearchInsKeyVal',i_err=(/info/)) goto 9999 end if idx(i) = lip @@ -678,14 +720,18 @@ contains cycle endif nxt = ncol + 1 - call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,idxmap%glb_lc,ncol) - if (lip < 0) & - & call psb_hash_searchinskey(ip,lip,nxt,idxmap%hash,info) + call hash_inner_cnv(ip,lip,idxmap%hashvmask,idxmap%hashv,& + & idxmap%glb_lc,ncol) + if (lip < 0) then + call psb_hash_searchinskey(ip,tlip,nxt,idxmap%hash,info) + lip = tlip + end if if (info >=0) then if (nxt == lip) then ncol = nxt - call psb_ensure_size(ncol,idxmap%loc_to_glob,info,pad=-ione,addsz=laddsz) + call psb_ensure_size(ncol,idxmap%loc_to_glob,info,& + & pad=-1_psb_lpk_,addsz=laddsz) if (info /= psb_success_) then info=1 ch_err='psb_ensure_size' @@ -725,20 +771,23 @@ contains end subroutine hash_g2lv1_ins subroutine hash_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) + use psb_realloc_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) - + integer(psb_lpk_), allocatable :: tidx(:) integer(psb_ipk_) :: is, im is = size(idxin) im = min(is,size(idxout)) - idxout(1:im) = idxin(1:im) - call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx) + call psb_realloc(im,tidx,info) + tidx(1:im) = idxin(1:im) + call idxmap%g2lip_ins(tidx(1:im),info,mask=mask,lidx=lidx) + idxout(1:im) = tidx(1:im) if (is > im) then write(0,*) 'g2lv2_ins err -3' info = -3 @@ -756,13 +805,15 @@ contains use psb_realloc_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: vl(:) + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_lpk_), intent(in) :: vl(:) integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_mpik_) :: iam, np - integer(psb_ipk_) :: i, nlu, nl, m, nrt,int_err(5) - integer(psb_ipk_), allocatable :: vlu(:), ix(:) + integer(psb_mpk_) :: iam, np + integer(psb_ipk_) :: i, nlu, nl, int_err(5) + integer(psb_lpk_) :: m, nrt + integer(psb_lpk_), allocatable :: vlu(:) + integer(psb_lpk_), allocatable :: ix(:) character(len=20), parameter :: name='hash_map_init_vl' info = 0 @@ -827,13 +878,14 @@ contains use psb_error_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: vg(:) integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_mpik_) :: iam, np - integer(psb_ipk_) :: i, j, nl, n, int_err(5) - integer(psb_ipk_), allocatable :: vlu(:) + integer(psb_mpk_) :: iam, np + integer(psb_ipk_) :: i, j, nl, int_err(5) + integer(psb_lpk_) :: n + integer(psb_lpk_), allocatable :: vlu(:) info = 0 call psb_info(ictxt,iam,np) @@ -886,11 +938,12 @@ contains use psb_realloc_mod implicit none class(psb_hash_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: vlu(:), nl, ntot + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_lpk_), intent(in) :: vlu(:), ntot + integer(psb_ipk_), intent(in) :: nl integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_mpik_) :: iam, np + integer(psb_mpk_) :: iam, np integer(psb_ipk_) :: i, j, lc2, nlu, m, nrt,int_err(5) character(len=20), parameter :: name='hash_map_init_vlu' @@ -943,9 +996,10 @@ contains class(psb_hash_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_mpik_) :: ictxt, iam, np + integer(psb_mpk_) :: ictxt, iam, np integer(psb_ipk_) :: i, j, m, nl - integer(psb_ipk_) :: key, ih, nh, idx, nbits, hsize, hmask + integer(psb_ipk_) :: ih, nh, idx, nbits + integer(psb_lpk_) :: key, hsize, hmask character(len=20), parameter :: name='hash_map_init_vlu' info = 0 @@ -984,7 +1038,7 @@ contains idxmap%hashvmask = hmask if (info == psb_success_) & - & call psb_realloc(hsize+1,idxmap%hashv,info,lb=0_psb_ipk_) + & call psb_realloc(hsize+1,idxmap%hashv,info,lb=0_psb_lpk_) if (info /= psb_success_) then ! !$ ch_err='psb_realloc' ! !$ call psb_errpush(info,name,a_err=ch_err) @@ -1046,7 +1100,7 @@ contains class(psb_hash_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_mpik_) :: ictxt, iam, np + integer(psb_mpk_) :: ictxt, iam, np integer(psb_ipk_) :: nhal info = 0 @@ -1081,11 +1135,13 @@ contains subroutine hash_inner_cnvs1(x,hashmask,hashv,glb_lc,nrm) - - integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) - integer(psb_ipk_), intent(inout) :: x + implicit none + integer(psb_lpk_), intent(in) :: hashmask,glb_lc(:,:) + integer(psb_ipk_), intent(in) :: hashv(0:) + integer(psb_lpk_), intent(inout) :: x integer(psb_ipk_), intent(in) :: nrm - integer(psb_ipk_) :: ih, key, idx,nh,tmp,lb,ub,lm + integer(psb_ipk_) :: idx,nh,tmp,lb,ub,lm + integer(psb_lpk_) :: key, ih ! ! When a large descriptor is assembled the indices ! are kept in a (hashed) list of ordered lists. @@ -1128,11 +1184,13 @@ contains end subroutine hash_inner_cnvs1 subroutine hash_inner_cnvs2(x,y,hashmask,hashv,glb_lc,nrm) - integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) - integer(psb_ipk_), intent(in) :: x + implicit none + integer(psb_ipk_), intent(in) :: hashv(0:) + integer(psb_lpk_), intent(in) :: hashmask, x, glb_lc(:,:) integer(psb_ipk_), intent(out) :: y integer(psb_ipk_), intent(in) :: nrm - integer(psb_ipk_) :: ih, key, idx,nh,tmp,lb,ub,lm + integer(psb_ipk_) :: idx,nh,tmp,lb,ub,lm + integer(psb_lpk_) :: ih, key ! ! When a large descriptor is assembled the indices ! are kept in a (hashed) list of ordered lists. @@ -1176,12 +1234,15 @@ contains subroutine hash_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask,nrm) - integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) + implicit none + integer(psb_ipk_), intent(in) :: n, hashv(0:) + integer(psb_lpk_), intent(in) :: glb_lc(:,:),hashmask logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: nrm - integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: x(:) - integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm + integer(psb_ipk_) :: i, nh,tmp,lb,ub,lm + integer(psb_lpk_) :: ih, key, idx ! ! When a large descriptor is assembled the indices ! are kept in a (hashed) list of ordered lists. @@ -1267,13 +1328,16 @@ contains end subroutine hash_inner_cnv1 subroutine hash_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask,nrm) - integer(psb_ipk_), intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) + implicit none + integer(psb_ipk_), intent(in) :: n, hashv(0:) + integer(psb_lpk_), intent(in) :: hashmask,glb_lc(:,:) logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: nrm - integer(psb_ipk_), intent(in) :: x(:) + integer(psb_lpk_), intent(in) :: x(:) integer(psb_ipk_), intent(out) :: y(:) - integer(psb_ipk_) :: i, ih, key, idx,nh,tmp,lb,ub,lm + integer(psb_ipk_) :: i, idx,nh,tmp,lb,ub,lm + integer(psb_lpk_) :: ih, key ! ! When a large descriptor is assembled the indices ! are kept in a (hashed) list of ordered lists. @@ -1434,6 +1498,7 @@ contains use psb_penv_mod use psb_error_mod use psb_realloc_mod + implicit none class(psb_hash_map), intent(in) :: idxmap type(psb_hash_map), intent(out) :: outmap integer(psb_ipk_) :: info @@ -1461,9 +1526,11 @@ contains implicit none class(psb_hash_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nr,nc,k, nl, ntot - integer(psb_mpik_) :: ictxt, me, np - integer(psb_ipk_), allocatable :: idx(:),lidx(:) + integer(psb_ipk_) :: err_act, nr,nc,k, nl + integer(psb_lpk_) :: ntot + integer(psb_mpk_) :: ictxt, me, np + integer(psb_ipk_), allocatable :: lidx(:) + integer(psb_lpk_), allocatable :: idx(:) character(len=20) :: name='hash_reinit' logical, parameter :: debug=.false. diff --git a/base/modules/aux/psb_hash_mod.f90 b/base/modules/desc/psb_hash_mod.F90 similarity index 62% rename from base/modules/aux/psb_hash_mod.f90 rename to base/modules/desc/psb_hash_mod.F90 index 23eac9758..66d0ca57e 100644 --- a/base/modules/aux/psb_hash_mod.f90 +++ b/base/modules/desc/psb_hash_mod.F90 @@ -33,7 +33,8 @@ ! module psb_hash_mod use psb_const_mod - use iso_c_binding + use psb_desc_const_mod + use psb_cbind_const_mod !> \class psb_hash_mod !! \brief Simple hash module for storing integer keys. !! @@ -58,25 +59,73 @@ module psb_hash_mod ! type psb_hash_type integer(psb_ipk_) :: nbits, hsize, hmask, nk - integer(psb_ipk_), allocatable :: table(:,:) - integer(psb_long_int_k_) :: nsrch, nacc + integer(psb_lpk_), allocatable :: table(:,:) + integer(psb_lpk_) :: nsrch, nacc end type psb_hash_type integer(psb_ipk_), parameter :: HashDuplicate = 123, HashOK=0, HashOutOfMemory=-512,& & HashFreeEntry = -1, HashNotFound = -256 - integer, parameter, private :: psb_c_int = c_int32_t + interface psb_hashval +#if defined(IPK4) + function psb_c_hashval_32(key) bind(c) result(res) + import psb_c_ipk + implicit none + integer(psb_c_ipk), value :: key + integer(psb_c_ipk) :: res + end function psb_c_hashval_32 +#endif +#if defined(IPK4) && defined(LPK8) + function psb_c_hashval_64_32(key) bind(c) result(res) + import psb_c_ipk, psb_c_lpk + implicit none + integer(psb_c_lpk), value :: key + integer(psb_c_ipk) :: res + end function psb_c_hashval_64_32 +#endif +#if defined(IPK8) + function psb_c_hashval_64(key) bind(c) result(res) + import psb_c_ipk + implicit none + integer(psb_c_ipk), value :: key + integer(psb_c_ipk) :: res + end function psb_c_hashval_64 +#endif + end interface psb_hashval + interface psb_hash_init - module procedure psb_hash_init_v, psb_hash_init_n - end interface - + module procedure psb_hash_init_lv, psb_hash_init_ln + end interface psb_hash_init + interface psb_sizeof module procedure psb_sizeof_hash_type end interface + + interface psb_hash_searchinskey + module procedure psb_hash_lsearchinskey + end interface psb_hash_searchinskey + + interface psb_hash_searchkey + module procedure psb_hash_lsearchkey + end interface psb_hash_searchkey +#if defined(IPK4) && defined(LPK8) + interface psb_hash_init + module procedure psb_hash_init_v, psb_hash_init_n + end interface + + interface psb_hash_searchinskey + module procedure psb_hash_isearchinskey + end interface psb_hash_searchinskey + + interface psb_hash_searchkey + module procedure psb_hash_isearchkey + end interface psb_hash_searchkey +#endif + interface psb_move_alloc module procedure HashTransfer end interface @@ -89,26 +138,17 @@ module psb_hash_mod module procedure HashFree end interface - interface psb_hashval - function psb_c_hashval_32(key) bind(c) result(res) - import psb_c_int - implicit none - integer(psb_c_int), value :: key - integer(psb_c_int) :: res - end function psb_c_hashval_32 - end interface psb_hashval - + contains function psb_Sizeof_hash_type(hash) result(val) type(psb_hash_type) :: hash - integer(psb_long_int_k_) :: val - val = 4*psb_sizeof_int + 2*psb_sizeof_long_int + integer(psb_epk_) :: val + val = 4*psb_sizeof_ip + 2*psb_sizeof_lp if (allocated(hash%table)) & - & val = val + psb_sizeof_int * size(hash%table) + & val = val + psb_sizeof_lp * size(hash%table) end function psb_Sizeof_hash_type - function psb_hash_avg_acc(hash) type(psb_hash_type), intent(in) :: hash @@ -183,7 +223,7 @@ contains end subroutine CloneHashTable - subroutine psb_hash_init_V(v,hash,info) + subroutine psb_hash_init_v(v,hash,info) integer(psb_ipk_), intent(in) :: v(:) type(psb_hash_type), intent(out) :: hash integer(psb_ipk_), intent(out) :: info @@ -202,7 +242,28 @@ contains return end if end do - end subroutine psb_hash_init_V + end subroutine psb_hash_init_v + + subroutine psb_hash_init_lv(v,hash,info) + integer(psb_lpk_), intent(in) :: v(:) + type(psb_hash_type), intent(out) :: hash + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: i,j, nv + + info = psb_success_ + nv = size(v) + call psb_hash_init(nv,hash,info) + if (info /= psb_success_) return + do i=1,nv + call psb_hash_searchinskey(v(i),j,i,hash,info) + if ((j /= i).or.(info /= HashOK)) then + write(psb_err_unit,*) 'Error from hash_ins',i,v(i),j,info + info = HashNotFound + return + end if + end do + end subroutine psb_hash_init_lv subroutine psb_hash_init_n(nv,hash,info) integer(psb_ipk_), intent(in) :: nv @@ -212,7 +273,7 @@ contains integer(psb_ipk_) :: hsize,nbits info = psb_success_ - nbits = 12 + nbits = psb_hash_bits hsize = 2**nbits ! ! Figure out the smallest power of 2 bigger than NV @@ -244,12 +305,52 @@ contains hash%nk = 0 end subroutine psb_hash_init_n + subroutine psb_hash_init_ln(nv,hash,info) + integer(psb_lpk_), intent(in) :: nv + type(psb_hash_type), intent(out) :: hash + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: hsize,nbits + + info = psb_success_ + nbits = psb_hash_bits + hsize = 2**nbits + ! + ! Figure out the smallest power of 2 bigger than NV + ! Note: in our intended usage NV will be the size of the + ! local index space, NOT the global index space. + ! + do + if (hsize < 0) then + write(psb_err_unit,*) 'Error: hash size overflow ',hsize,nbits + info = -2 + return + end if + if (hsize > nv) exit + nbits = nbits + 1 + hsize = hsize * 2 + end do + hash%nbits = nbits + hash%hsize = hsize + hash%hmask = hsize-1 + hash%nsrch = 0 + hash%nacc = 0 + allocate(hash%table(0:hsize-1,2),stat=info) + if (info /= psb_success_) then + write(psb_err_unit,*) 'Error: memory allocation failure ',hsize + info = HashOutOfMemory + return + end if + hash%table = HashFreeEntry + hash%nk = 0 + end subroutine psb_hash_init_ln + subroutine psb_hash_realloc(hash,info) type(psb_hash_type), intent(inout) :: hash integer(psb_ipk_), intent(out) :: info type(psb_hash_type) :: nhash - integer(psb_ipk_) :: key, val, nextval,i + integer(psb_lpk_) :: key, val, nextval,i info = HashOk @@ -273,7 +374,68 @@ contains call HashTransfer(nhash,hash,info) end subroutine psb_hash_realloc - recursive subroutine psb_hash_searchinskey(key,val,nextval,hash,info) + recursive subroutine psb_hash_lsearchinskey(key,val,nextval,hash,info) + integer(psb_lpk_), intent(in) :: key,nextval + type(psb_hash_type) :: hash + integer(psb_lpk_), intent(out) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: hsize,hmask, hk, hd + + info = HashOK + hsize = hash%hsize + hmask = hash%hmask + + hk = iand(psb_hashval(key),hmask) + if (hk == 0) then + hd = 1 + else + hd = hsize - hk + hd = ior(hd,1) + end if + if (.not.allocated(hash%table)) then + info = HashOutOfMemory + return + end if + + hash%nsrch = hash%nsrch + 1 + do + hash%nacc = hash%nacc + 1 + if (hash%table(hk,1) == key) then + val = hash%table(hk,2) + info = HashDuplicate + return + end if + if (hash%table(hk,1) == HashFreeEntry) then + if (hash%nk == hash%hsize -1) then + ! + ! Note: because of the way we allocate things at CDALL + ! time this is really unlikely; if we get here, we + ! have at least as many halo indices as internals, which + ! means we're already in trouble. But we try to keep going. + ! + call psb_hash_realloc(hash,info) + if (info /= HashOk) then + info = HashOutOfMemory + return + else + call psb_hash_searchinskey(key,val,nextval,hash,info) + return + end if + else + hash%nk = hash%nk + 1 + hash%table(hk,1) = key + hash%table(hk,2) = nextval + val = nextval + return + end if + end if + hk = hk - hd + if (hk < 0) hk = hk + hsize + end do + end subroutine psb_hash_lsearchinskey + + recursive subroutine psb_hash_isearchinskey(key,val,nextval,hash,info) integer(psb_ipk_), intent(in) :: key,nextval type(psb_hash_type) :: hash integer(psb_ipk_), intent(out) :: val, info @@ -331,15 +493,56 @@ contains hk = hk - hd if (hk < 0) hk = hk + hsize end do - end subroutine psb_hash_searchinskey + end subroutine psb_hash_isearchinskey - subroutine psb_hash_searchkey(key,val,hash,info) + subroutine psb_hash_isearchkey(key,val,hash,info) integer(psb_ipk_), intent(in) :: key type(psb_hash_type) :: hash integer(psb_ipk_), intent(out) :: val, info integer(psb_ipk_) :: hsize,hmask, hk, hd + info = HashOK + if (.not.allocated(hash%table) ) then + val = HashFreeEntry + return + end if + hsize = hash%hsize + hmask = hash%hmask + hk = iand(psb_hashval(key),hmask) + + if (hk == 0) then + hd = 1 + else + hd = hsize - hk + hd = ior(hd,1) + end if + + hash%nsrch = hash%nsrch + 1 + do + hash%nacc = hash%nacc + 1 + if (hash%table(hk,1) == key) then + val = hash%table(hk,2) + return + end if + if (hash%table(hk,1) == HashFreeEntry) then + val = HashFreeEntry +! !$ info = HashNotFound + return + end if + hk = hk - hd + if (hk < 0) hk = hk + hsize + end do + end subroutine psb_hash_isearchkey + + subroutine psb_hash_lsearchkey(key,val,hash,info) + integer(psb_lpk_), intent(in) :: key + type(psb_hash_type) :: hash + integer(psb_lpk_), intent(out) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: hsize,hmask, hk, hd + info = HashOK if (.not.allocated(hash%table) ) then val = HashFreeEntry @@ -370,6 +573,6 @@ contains hk = hk - hd if (hk < 0) hk = hk + hsize end do - end subroutine psb_hash_searchkey + end subroutine psb_hash_lsearchkey end module psb_hash_mod diff --git a/base/modules/desc/psb_hashval.c b/base/modules/desc/psb_hashval.c new file mode 100644 index 000000000..15cfc448e --- /dev/null +++ b/base/modules/desc/psb_hashval.c @@ -0,0 +1,49 @@ +#include +/* + This is based on the djb2 hashing algorithm + see e.g. http://www.cse.yorku.ca/~oz/hash.html +*/ + +#define IVAL 5381 +#define H32MASK 0x7FFFFFFF +#define H64MASK 0x7FFFFFFFFFFFFFFF +#define BMASK 0xFF + +int32_t psb_c_hashval_32(int32_t inkey) +{ + uint32_t key, val, i; + key = inkey; + val = IVAL; + for (i=0; i<4; i++) { + val = ((val<<5)+val)+(key & BMASK); + key >>= 8; + } + val &= H32MASK; + return(val); +} + +int64_t psb_c_hashval_64(int64_t inkey) +{ + uint64_t key, val, i; + key = inkey; + val = IVAL; + for (i=0; i<8; i++) { + val = ((val<<5)+val)+(key & BMASK); + key >>= 8; + } + val &= H64MASK; + return(val); +} + +int32_t psb_c_hashval_64_32(int64_t inkey) +{ + uint32_t key, val, i; + key = inkey; + val = IVAL; + for (i=0; i<8; i++) { + val = ((val<<5)+val)+(key & BMASK); + key >>= 8; + } + val &= H32MASK; + return(val); +} diff --git a/base/modules/desc/psb_indx_map_mod.f90 b/base/modules/desc/psb_indx_map_mod.f90 index fcfb666ba..7ad517d31 100644 --- a/base/modules/desc/psb_indx_map_mod.f90 +++ b/base/modules/desc/psb_indx_map_mod.f90 @@ -108,13 +108,13 @@ module psb_indx_map_mod !> State of the map integer(psb_ipk_) :: state = psb_desc_null_ !> Communication context - integer(psb_mpik_) :: ictxt = -1 + integer(psb_mpk_) :: ictxt = -1 !> MPI communicator - integer(psb_mpik_) :: mpic = -1 + integer(psb_mpk_) :: mpic = -1 !> Number of global rows - integer(psb_ipk_) :: global_rows = -1 + integer(psb_lpk_) :: global_rows = -1 !> Number of global columns - integer(psb_ipk_) :: global_cols = -1 + integer(psb_lpk_) :: global_cols = -1 !> Number of local rows integer(psb_ipk_) :: local_rows = -1 !> Number of local columns @@ -141,19 +141,26 @@ module psb_indx_map_mod procedure, pass(idxmap) :: get_gc => base_get_gc procedure, pass(idxmap) :: get_lr => base_get_lr procedure, pass(idxmap) :: get_lc => base_get_lc + + + procedure, pass(idxmap) :: set_gri => base_set_gri + procedure, pass(idxmap) :: set_gci => base_set_gci + procedure, pass(idxmap) :: set_grl => base_set_grl + procedure, pass(idxmap) :: set_gcl => base_set_gcl + generic, public :: set_gr => set_grl + generic, public :: set_gc => set_gcl + + procedure, pass(idxmap) :: set_lr => base_set_lr + procedure, pass(idxmap) :: set_lc => base_set_lc + + procedure, pass(idxmap) :: set_ctxt => base_set_ctxt + procedure, pass(idxmap) :: set_mpic => base_set_mpic procedure, pass(idxmap) :: get_ctxt => base_get_ctxt procedure, pass(idxmap) :: get_mpic => base_get_mpic procedure, pass(idxmap) :: sizeof => base_sizeof procedure, pass(idxmap) :: set_null => base_set_null procedure, nopass :: row_extendable => base_row_extendable - procedure, pass(idxmap) :: set_gr => base_set_gr - procedure, pass(idxmap) :: set_gc => base_set_gc - procedure, pass(idxmap) :: set_lr => base_set_lr - procedure, pass(idxmap) :: set_lc => base_set_lc - procedure, pass(idxmap) :: set_ctxt => base_set_ctxt - procedure, pass(idxmap) :: set_mpic => base_set_mpic - procedure, nopass :: get_fmt => base_get_fmt procedure, pass(idxmap) :: asb => base_asb @@ -161,26 +168,44 @@ module psb_indx_map_mod procedure, pass(idxmap) :: clone => base_clone procedure, pass(idxmap) :: reinit => base_reinit - procedure, pass(idxmap) :: l2gs1 => base_l2gs1 - procedure, pass(idxmap) :: l2gs2 => base_l2gs2 - procedure, pass(idxmap) :: l2gv1 => base_l2gv1 - procedure, pass(idxmap) :: l2gv2 => base_l2gv2 - generic, public :: l2g => l2gs2, l2gv2 - generic, public :: l2gip => l2gs1, l2gv1 +!!$ procedure, pass(idxmap) :: l2gs1 => base_l2gs1 +!!$ procedure, pass(idxmap) :: l2gs2 => base_l2gs2 +!!$ procedure, pass(idxmap) :: l2gv1 => base_l2gv1 +!!$ procedure, pass(idxmap) :: l2gv2 => base_l2gv2 + procedure, pass(idxmap) :: ll2gs1 => base_ll2gs1 + procedure, pass(idxmap) :: ll2gs2 => base_ll2gs2 + procedure, pass(idxmap) :: ll2gv1 => base_ll2gv1 + procedure, pass(idxmap) :: ll2gv2 => base_ll2gv2 +!!$ generic, public :: l2g => l2gs2, l2gv2 +!!$ generic, public :: l2gip => l2gs1, l2gv1 + generic, public :: l2g => ll2gs2, ll2gv2 + generic, public :: l2gip => ll2gs1, ll2gv1 - procedure, pass(idxmap) :: g2ls1 => base_g2ls1 - procedure, pass(idxmap) :: g2ls2 => base_g2ls2 - procedure, pass(idxmap) :: g2lv1 => base_g2lv1 - procedure, pass(idxmap) :: g2lv2 => base_g2lv2 - generic, public :: g2l => g2ls2, g2lv2 - generic, public :: g2lip => g2ls1, g2lv1 +!!$ procedure, pass(idxmap) :: g2ls1 => base_g2ls1 +!!$ procedure, pass(idxmap) :: g2ls2 => base_g2ls2 +!!$ procedure, pass(idxmap) :: g2lv1 => base_g2lv1 +!!$ procedure, pass(idxmap) :: g2lv2 => base_g2lv2 + procedure, pass(idxmap) :: lg2ls1 => base_lg2ls1 + procedure, pass(idxmap) :: lg2ls2 => base_lg2ls2 + procedure, pass(idxmap) :: lg2lv1 => base_lg2lv1 + procedure, pass(idxmap) :: lg2lv2 => base_lg2lv2 +!!$ generic, public :: g2l => g2ls2, g2lv2 +!!$ generic, public :: g2lip => g2ls1, g2lv1 + generic, public :: g2l => lg2ls2, lg2lv2 + generic, public :: g2lip => lg2ls1, lg2lv1 - procedure, pass(idxmap) :: g2ls1_ins => base_g2ls1_ins - procedure, pass(idxmap) :: g2ls2_ins => base_g2ls2_ins - procedure, pass(idxmap) :: g2lv1_ins => base_g2lv1_ins - procedure, pass(idxmap) :: g2lv2_ins => base_g2lv2_ins - generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins - generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins +!!$ procedure, pass(idxmap) :: g2ls1_ins => base_g2ls1_ins +!!$ procedure, pass(idxmap) :: g2ls2_ins => base_g2ls2_ins +!!$ procedure, pass(idxmap) :: g2lv1_ins => base_g2lv1_ins +!!$ procedure, pass(idxmap) :: g2lv2_ins => base_g2lv2_ins + procedure, pass(idxmap) :: lg2ls1_ins => base_lg2ls1_ins + procedure, pass(idxmap) :: lg2ls2_ins => base_lg2ls2_ins + procedure, pass(idxmap) :: lg2lv1_ins => base_lg2lv1_ins + procedure, pass(idxmap) :: lg2lv2_ins => base_lg2lv2_ins +!!$ generic, public :: g2l_ins => g2ls2_ins, g2lv2_ins +!!$ generic, public :: g2lip_ins => g2ls1_ins, g2lv1_ins + generic, public :: g2l_ins => lg2ls2_ins, lg2lv2_ins + generic, public :: g2lip_ins => lg2ls1_ins, lg2lv1_ins procedure, pass(idxmap) :: fnd_owner => psb_indx_map_fnd_owner procedure, pass(idxmap) :: init_vl => base_init_vl @@ -191,13 +216,17 @@ module psb_indx_map_mod private :: base_get_state, base_set_state, base_is_repl, base_is_bld,& & base_is_upd, base_is_asb, base_is_valid, base_is_ovl,& & base_get_gr, base_get_gc, base_get_lr, base_get_lc, base_get_ctxt,& - & base_get_mpic, base_sizeof, base_set_null, base_set_gr,& - & base_set_gc, base_set_lr, base_set_lc, base_set_ctxt,& + & base_get_mpic, base_sizeof, base_set_null, & + & base_set_grl, base_set_gcl, & + & base_set_lr, base_set_lc, base_set_ctxt,& & base_set_mpic, base_get_fmt, base_asb, base_free,& & base_l2gs1, base_l2gs2, base_l2gv1, base_l2gv2,& & base_g2ls1, base_g2ls2, base_g2lv1, base_g2lv2,& - & base_g2ls1_ins, base_g2ls2_ins, base_g2lv1_ins,& - & base_g2lv2_ins, base_init_vl, base_is_null,& + & base_g2ls1_ins, base_g2ls2_ins, base_g2lv1_ins, base_g2lv2_ins, & + & base_ll2gs1, base_ll2gs2, base_ll2gv1, base_ll2gv2,& + & base_lg2ls1, base_lg2ls2, base_lg2lv1, base_lg2lv2,& + & base_lg2ls1_ins, base_lg2ls2_ins, base_lg2lv1_ins,& + & base_lg2lv2_ins, base_init_vl, base_is_null,& & base_row_extendable, base_clone, base_reinit !> Function: psb_indx_map_fnd_owner @@ -220,9 +249,9 @@ module psb_indx_map_mod interface subroutine psb_indx_map_fnd_owner(idx,iprc,idxmap,info) - import :: psb_indx_map, psb_ipk_ + import :: psb_indx_map, psb_ipk_, psb_lpk_ implicit none - integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_indx_map), intent(in) :: idxmap integer(psb_ipk_), intent(out) :: info @@ -255,7 +284,7 @@ contains function base_get_gr(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_) :: val + integer(psb_lpk_) :: val val = idxmap%global_rows @@ -265,7 +294,7 @@ contains function base_get_gc(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap - integer(psb_ipk_) :: val + integer(psb_lpk_) :: val val = idxmap%global_cols @@ -295,7 +324,7 @@ contains function base_get_ctxt(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap - integer(psb_mpik_) :: val + integer(psb_mpk_) :: val val = idxmap%ictxt @@ -305,7 +334,7 @@ contains function base_get_mpic(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap - integer(psb_mpik_) :: val + integer(psb_mpk_) :: val val = idxmap%mpic @@ -323,26 +352,42 @@ contains subroutine base_set_ctxt(idxmap,val) implicit none class(psb_indx_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: val + integer(psb_mpk_), intent(in) :: val idxmap%ictxt = val end subroutine base_set_ctxt - subroutine base_set_gr(idxmap,val) + subroutine base_set_gri(idxmap,val) implicit none class(psb_indx_map), intent(inout) :: idxmap integer(psb_ipk_), intent(in) :: val idxmap%global_rows = val - end subroutine base_set_gr + end subroutine base_set_gri - subroutine base_set_gc(idxmap,val) + subroutine base_set_gci(idxmap,val) implicit none class(psb_indx_map), intent(inout) :: idxmap integer(psb_ipk_), intent(in) :: val idxmap%global_cols = val - end subroutine base_set_gc + end subroutine base_set_gci + + subroutine base_set_grl(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(in) :: val + + idxmap%global_rows = val + end subroutine base_set_grl + + subroutine base_set_gcl(idxmap,val) + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(in) :: val + + idxmap%global_cols = val + end subroutine base_set_gcl subroutine base_set_lr(idxmap,val) implicit none @@ -363,7 +408,7 @@ contains subroutine base_set_mpic(idxmap,val) implicit none class(psb_indx_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: val + integer(psb_mpk_), intent(in) :: val idxmap%mpic = val end subroutine base_set_mpic @@ -434,9 +479,9 @@ contains function base_sizeof(idxmap) result(val) implicit none class(psb_indx_map), intent(in) :: idxmap - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val - val = 8 * psb_sizeof_int + val = 8 * psb_sizeof_ip end function base_sizeof @@ -541,6 +586,107 @@ contains end subroutine base_l2gv2 + !> + !! \memberof psb_indx_map + !! \brief Local to global, scalar, in place + subroutine base_ll2gs1(idx,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_ll2g' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_ll2gs1 + + subroutine base_ll2gs2(idxin,idxout,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(out) :: idxout + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_ll2g' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + + end subroutine base_ll2gs2 + + + subroutine base_ll2gv1(idx,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_ll2g' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + end subroutine base_ll2gv1 + + subroutine base_ll2gv2(idxin,idxout,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(out) :: idxout(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_ll2g' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_ll2gv2 + subroutine base_g2ls1(idx,idxmap,info,mask,owned) use psb_error_mod @@ -644,6 +790,106 @@ contains end subroutine base_g2lv2 + subroutine base_lg2ls1(idx,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_lg2l' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_lg2ls1 + + subroutine base_lg2ls2(idxin,idxout,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_lpk_), intent(in) :: idxin + integer(psb_ipk_), intent(out) :: idxout + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + logical, intent(in), optional :: owned + + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_lg2l' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_lg2ls2 + + + subroutine base_lg2lv1(idx,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_lg2l' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_lg2lv1 + + subroutine base_lg2lv2(idxin,idxout,idxmap,info,mask,owned) + use psb_error_mod + implicit none + class(psb_indx_map), intent(in) :: idxmap + integer(psb_lpk_), intent(in) :: idxin(:) + integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + logical, intent(in), optional :: owned + + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_lg2l' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_lg2lv2 subroutine base_g2ls1_ins(idx,idxmap,info,mask, lidx) @@ -749,6 +995,108 @@ contains end subroutine base_g2lv2_ins + subroutine base_lg2ls1_ins(idx,idxmap,info,mask, lidx) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(inout) :: idx + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + integer(psb_ipk_), intent(in), optional :: lidx + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_lg2l_ins' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_lg2ls1_ins + + subroutine base_lg2ls2_ins(idxin,idxout,idxmap,info,mask, lidx) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(in) :: idxin + integer(psb_ipk_), intent(out) :: idxout + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask + integer(psb_ipk_), intent(in), optional :: lidx + + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_lg2l_ins' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_lg2ls2_ins + + + subroutine base_lg2lv1_ins(idx,idxmap,info,mask, lidx) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + integer(psb_ipk_), intent(in), optional :: lidx(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_lg2l_ins' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_lg2lv1_ins + + subroutine base_lg2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) + use psb_error_mod + implicit none + class(psb_indx_map), intent(inout) :: idxmap + integer(psb_lpk_), intent(in) :: idxin(:) + integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: mask(:) + integer(psb_ipk_), intent(in), optional :: lidx(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_lg2l_ins' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,& + & name,a_err=idxmap%get_fmt()) + + call psb_error_handler(err_act) + return + + end subroutine base_lg2lv2_ins + subroutine base_asb(idxmap,info) use psb_error_mod implicit none @@ -808,8 +1156,8 @@ contains use psb_error_mod implicit none class(psb_indx_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: vl(:) + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_lpk_), intent(in) :: vl(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act character(len=20) :: name='base_init_vl' diff --git a/base/modules/desc/psb_list_map_mod.f90 b/base/modules/desc/psb_list_map_mod.f90 index a11e39ab6..1256d78e6 100644 --- a/base/modules/desc/psb_list_map_mod.f90 +++ b/base/modules/desc/psb_list_map_mod.f90 @@ -46,9 +46,10 @@ module psb_list_map_mod type, extends(psb_indx_map) :: psb_list_map integer(psb_ipk_) :: pnt_h = -1 - integer(psb_ipk_), allocatable :: loc_to_glob(:), glob_to_loc(:) + integer(psb_lpk_), allocatable :: loc_to_glob(:) + integer(psb_ipk_), allocatable :: glob_to_loc(:) contains - procedure, pass(idxmap) :: init_vl => list_initvl + procedure, pass(idxmap) :: init_vl => list_initlvl procedure, pass(idxmap) :: sizeof => list_sizeof procedure, pass(idxmap) :: asb => list_asb @@ -58,20 +59,35 @@ module psb_list_map_mod procedure, nopass :: get_fmt => list_get_fmt procedure, nopass :: row_extendable => list_row_extendable - procedure, pass(idxmap) :: l2gs1 => list_l2gs1 - procedure, pass(idxmap) :: l2gs2 => list_l2gs2 - procedure, pass(idxmap) :: l2gv1 => list_l2gv1 - procedure, pass(idxmap) :: l2gv2 => list_l2gv2 +!!$ procedure, pass(idxmap) :: l2gs1 => list_l2gs1 +!!$ procedure, pass(idxmap) :: l2gs2 => list_l2gs2 +!!$ procedure, pass(idxmap) :: l2gv1 => list_l2gv1 +!!$ procedure, pass(idxmap) :: l2gv2 => list_l2gv2 - procedure, pass(idxmap) :: g2ls1 => list_g2ls1 - procedure, pass(idxmap) :: g2ls2 => list_g2ls2 - procedure, pass(idxmap) :: g2lv1 => list_g2lv1 - procedure, pass(idxmap) :: g2lv2 => list_g2lv2 + procedure, pass(idxmap) :: ll2gs1 => list_ll2gs1 + procedure, pass(idxmap) :: ll2gs2 => list_ll2gs2 + procedure, pass(idxmap) :: ll2gv1 => list_ll2gv1 + procedure, pass(idxmap) :: ll2gv2 => list_ll2gv2 - procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins - procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins - procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins - procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins +!!$ procedure, pass(idxmap) :: g2ls1 => list_g2ls1 +!!$ procedure, pass(idxmap) :: g2ls2 => list_g2ls2 +!!$ procedure, pass(idxmap) :: g2lv1 => list_g2lv1 +!!$ procedure, pass(idxmap) :: g2lv2 => list_g2lv2 + + procedure, pass(idxmap) :: lg2ls1 => list_lg2ls1 + procedure, pass(idxmap) :: lg2ls2 => list_lg2ls2 + procedure, pass(idxmap) :: lg2lv1 => list_lg2lv1 + procedure, pass(idxmap) :: lg2lv2 => list_lg2lv2 + +!!$ procedure, pass(idxmap) :: g2ls1_ins => list_g2ls1_ins +!!$ procedure, pass(idxmap) :: g2ls2_ins => list_g2ls2_ins +!!$ procedure, pass(idxmap) :: g2lv1_ins => list_g2lv1_ins +!!$ procedure, pass(idxmap) :: g2lv2_ins => list_g2lv2_ins + + procedure, pass(idxmap) :: lg2ls1_ins => list_lg2ls1_ins + procedure, pass(idxmap) :: lg2ls2_ins => list_lg2ls2_ins + procedure, pass(idxmap) :: lg2lv1_ins => list_lg2lv1_ins + procedure, pass(idxmap) :: lg2lv2_ins => list_lg2lv2_ins end type psb_list_map @@ -94,14 +110,14 @@ contains function list_sizeof(idxmap) result(val) implicit none class(psb_list_map), intent(in) :: idxmap - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = idxmap%psb_indx_map%sizeof() if (allocated(idxmap%loc_to_glob)) & - & val = val + size(idxmap%loc_to_glob)*psb_sizeof_int + & val = val + size(idxmap%loc_to_glob)*psb_sizeof_ip if (allocated(idxmap%glob_to_loc)) & - & val = val + size(idxmap%glob_to_loc)*psb_sizeof_int + & val = val + size(idxmap%glob_to_loc)*psb_sizeof_ip end function list_sizeof @@ -120,14 +136,122 @@ contains end subroutine list_free - subroutine list_l2gs1(idx,idxmap,info,mask,owned) +!!$ subroutine list_l2gs1(idx,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_list_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: idxv(1) +!!$ info = 0 +!!$ if (present(mask)) then +!!$ if (.not.mask) return +!!$ end if +!!$ +!!$ idxv(1) = idx +!!$ call idxmap%l2gip(idxv,info,owned=owned) +!!$ idx = idxv(1) +!!$ +!!$ end subroutine list_l2gs1 +!!$ +!!$ subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_list_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin +!!$ integer(psb_ipk_), intent(out) :: idxout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ logical, intent(in), optional :: owned +!!$ +!!$ idxout = idxin +!!$ call idxmap%l2gip(idxout,info,mask,owned) +!!$ +!!$ end subroutine list_l2gs2 +!!$ +!!$ +!!$ subroutine list_l2gv1(idx,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_list_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: i +!!$ logical :: owned_ +!!$ info = 0 +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < size(idx)) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(owned)) then +!!$ owned_ = owned +!!$ else +!!$ owned_ = .false. +!!$ end if +!!$ +!!$ if (present(mask)) then +!!$ +!!$ do i=1, size(idx) +!!$ if (mask(i)) then +!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then +!!$ idx(i) = idxmap%loc_to_glob(idx(i)) +!!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)& +!!$ & .and.(.not.owned_)) then +!!$ idx(i) = idxmap%loc_to_glob(idx(i)) +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, size(idx) +!!$ if ((1<=idx(i)).and.(idx(i) <= idxmap%get_lr())) then +!!$ idx(i) = idxmap%loc_to_glob(idx(i)) +!!$ else if ((idxmap%get_lr() < idx(i)).and.(idx(i) <= idxmap%local_cols)& +!!$ & .and.(.not.owned_)) then +!!$ idx(i) = idxmap%loc_to_glob(idx(i)) +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end do +!!$ +!!$ end if +!!$ +!!$ end subroutine list_l2gv1 +!!$ +!!$ subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_list_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin(:) +!!$ integer(psb_ipk_), intent(out) :: idxout(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: is, im +!!$ +!!$ is = size(idxin) +!!$ im = min(is,size(idxout)) +!!$ idxout(1:im) = idxin(1:im) +!!$ call idxmap%l2gip(idxout(1:im),info,mask,owned) +!!$ if (is > im) info = -3 +!!$ +!!$ end subroutine list_l2gv2 +!!$ + + subroutine list_ll2gs1(idx,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - integer(psb_ipk_) :: idxv(1) + integer(psb_lpk_) :: idxv(1) info = 0 if (present(mask)) then if (.not.mask) return @@ -137,13 +261,13 @@ contains call idxmap%l2gip(idxv,info,owned=owned) idx = idxv(1) - end subroutine list_l2gs1 + end subroutine list_ll2gs1 - subroutine list_l2gs2(idxin,idxout,idxmap,info,mask,owned) + subroutine list_ll2gs2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap integer(psb_ipk_), intent(in) :: idxin - integer(psb_ipk_), intent(out) :: idxout + integer(psb_lpk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned @@ -151,17 +275,17 @@ contains idxout = idxin call idxmap%l2gip(idxout,info,mask,owned) - end subroutine list_l2gs2 + end subroutine list_ll2gs2 - subroutine list_l2gv1(idx,idxmap,info,mask,owned) + subroutine list_ll2gv1(idx,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: i + integer(psb_lpk_) :: i logical :: owned_ info = 0 @@ -207,17 +331,17 @@ contains end if - end subroutine list_l2gv1 + end subroutine list_ll2gv1 - subroutine list_l2gv2(idxin,idxout,idxmap,info,mask,owned) + subroutine list_ll2gv2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap integer(psb_ipk_), intent(in) :: idxin(:) - integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_lpk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: is, im + integer(psb_lpk_) :: is, im is = size(idxin) im = min(is,size(idxout)) @@ -225,17 +349,139 @@ contains call idxmap%l2gip(idxout(1:im),info,mask,owned) if (is > im) info = -3 - end subroutine list_l2gv2 + end subroutine list_ll2gv2 + +!!$ +!!$ subroutine list_g2ls1(idx,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_list_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: idxv(1) +!!$ info = 0 +!!$ +!!$ if (present(mask)) then +!!$ if (.not.mask) return +!!$ end if +!!$ +!!$ idxv(1) = idx +!!$ call idxmap%g2lip(idxv,info,owned=owned) +!!$ idx = idxv(1) +!!$ +!!$ end subroutine list_g2ls1 +!!$ +!!$ subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_list_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin +!!$ integer(psb_ipk_), intent(out) :: idxout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ logical, intent(in), optional :: owned +!!$ +!!$ idxout = idxin +!!$ call idxmap%g2lip(idxout,info,mask,owned) +!!$ +!!$ end subroutine list_g2ls2 +!!$ +!!$ +!!$ subroutine list_g2lv1(idx,idxmap,info,mask,owned) +!!$ use psb_sort_mod +!!$ implicit none +!!$ class(psb_list_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ logical, intent(in), optional :: owned +!!$ integer(psb_ipk_) :: i, is, ix +!!$ logical :: owned_ +!!$ +!!$ info = 0 +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < size(idx)) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(owned)) then +!!$ owned_ = owned +!!$ else +!!$ owned_ = .false. +!!$ end if +!!$ +!!$ is = size(idx) +!!$ +!!$ if (present(mask)) then +!!$ if (idxmap%is_valid()) then +!!$ do i=1,is +!!$ if (mask(i)) then +!!$ if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ ix = idxmap%glob_to_loc(idx(i)) +!!$ if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 +!!$ idx(i) = ix +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ else +!!$ idx(1:is) = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ if (idxmap%is_valid()) then +!!$ do i=1, is +!!$ if ((1 <= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ ix = idxmap%glob_to_loc(idx(i)) +!!$ if ((ix > idxmap%get_lr()).and.(owned_)) ix = -1 +!!$ idx(i) = ix +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end do +!!$ else +!!$ idx(1:is) = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ end if +!!$ +!!$ end subroutine list_g2lv1 +!!$ +!!$ subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned) +!!$ implicit none +!!$ class(psb_list_map), intent(in) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin(:) +!!$ integer(psb_ipk_), intent(out) :: idxout(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ logical, intent(in), optional :: owned +!!$ +!!$ integer(psb_ipk_) :: is, im +!!$ +!!$ is = size(idxin) +!!$ im = min(is,size(idxout)) +!!$ idxout(1:im) = idxin(1:im) +!!$ call idxmap%g2lip(idxout(1:im),info,mask,owned) +!!$ if (is > im) info = -3 +!!$ +!!$ end subroutine list_g2lv2 - subroutine list_g2ls1(idx,idxmap,info,mask,owned) + + subroutine list_lg2ls1(idx,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - integer(psb_ipk_) :: idxv(1) + integer(psb_lpk_) :: idxv(1) info = 0 if (present(mask)) then @@ -246,32 +492,39 @@ contains call idxmap%g2lip(idxv,info,owned=owned) idx = idxv(1) - end subroutine list_g2ls1 + end subroutine list_lg2ls1 - subroutine list_g2ls2(idxin,idxout,idxmap,info,mask,owned) + subroutine list_lg2ls2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - - idxout = idxin - call idxmap%g2lip(idxout,info,mask,owned) + integer(psb_lpk_) :: idxv(1) - end subroutine list_g2ls2 + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv = idxin + call idxmap%g2lip(idxv,info,owned=owned) + idxout = idxv(1) + + end subroutine list_lg2ls2 - subroutine list_g2lv1(idx,idxmap,info,mask,owned) + subroutine list_lg2lv1(idx,idxmap,info,mask,owned) use psb_sort_mod implicit none class(psb_list_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: i, is, ix + integer(psb_lpk_) :: i, is, ix logical :: owned_ info = 0 @@ -327,40 +580,249 @@ contains end if - end subroutine list_g2lv1 + end subroutine list_lg2lv1 - subroutine list_g2lv2(idxin,idxout,idxmap,info,mask,owned) + subroutine list_lg2lv2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_list_map), intent(in) :: idxmap - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - + integer(psb_lpk_), allocatable :: idxv(:) integer(psb_ipk_) :: is, im is = size(idxin) im = min(is,size(idxout)) - idxout(1:im) = idxin(1:im) - call idxmap%g2lip(idxout(1:im),info,mask,owned) + allocate(idxv(im),stat=info) + if (info /= 0) then + info = -5 + return + end if + idxv(1:im) = idxin(1:im) + call idxmap%g2lip(idxv(1:im),info,mask,owned) + idxout(1:im) = idxv(1:im) if (is > im) info = -3 - end subroutine list_g2lv2 + end subroutine list_lg2lv2 +!!$ subroutine list_g2ls1_ins(idx,idxmap,info,mask,lidx) +!!$ use psb_realloc_mod +!!$ use psb_sort_mod +!!$ implicit none +!!$ class(psb_list_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ integer(psb_ipk_), intent(in), optional :: lidx +!!$ +!!$ integer(psb_ipk_) :: idxv(1), lidxv(1) +!!$ +!!$ info = 0 +!!$ if (present(mask)) then +!!$ if (.not.mask) return +!!$ end if +!!$ idxv(1) = idx +!!$ if (present(lidx)) then +!!$ lidxv(1) = lidx +!!$ call idxmap%g2lip_ins(idxv,info,lidx=lidxv) +!!$ else +!!$ call idxmap%g2lip_ins(idxv,info) +!!$ end if +!!$ +!!$ idx = idxv(1) +!!$ +!!$ end subroutine list_g2ls1_ins +!!$ +!!$ subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) +!!$ implicit none +!!$ class(psb_list_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin +!!$ integer(psb_ipk_), intent(out) :: idxout +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask +!!$ integer(psb_ipk_), intent(in), optional :: lidx +!!$ +!!$ idxout = idxin +!!$ call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) +!!$ +!!$ end subroutine list_g2ls2_ins +!!$ +!!$ +!!$ subroutine list_g2lv1_ins(idx,idxmap,info,mask,lidx) +!!$ use psb_realloc_mod +!!$ use psb_sort_mod +!!$ implicit none +!!$ class(psb_list_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(inout) :: idx(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ integer(psb_ipk_), intent(in), optional :: lidx(:) +!!$ +!!$ integer(psb_ipk_) :: i, is, ix, lix +!!$ +!!$ info = 0 +!!$ is = size(idx) +!!$ +!!$ if (present(mask)) then +!!$ if (size(mask) < size(idx)) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ if (present(lidx)) then +!!$ if (size(lidx) < size(idx)) then +!!$ info = -1 +!!$ return +!!$ end if +!!$ end if +!!$ +!!$ +!!$ if (idxmap%is_asb()) then +!!$ ! State is wrong for this one ! +!!$ idx = -1 +!!$ info = -1 +!!$ +!!$ else if (idxmap%is_valid()) then +!!$ +!!$ if (present(lidx)) then +!!$ if (present(mask)) then +!!$ do i=1, is +!!$ if (mask(i)) then +!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ ix = idxmap%glob_to_loc(idx(i)) +!!$ if (ix < 0) then +!!$ ix = lidx(i) +!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if ((ix <= idxmap%local_rows).or.(info /= 0)) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = max(ix,idxmap%local_cols) +!!$ idxmap%loc_to_glob(ix) = idx(i) +!!$ idxmap%glob_to_loc(idx(i)) = ix +!!$ end if +!!$ idx(i) = ix +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, is +!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ ix = idxmap%glob_to_loc(idx(i)) +!!$ if (ix < 0) then +!!$ ix = lidx(i) +!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if ((ix <= idxmap%local_rows).or.(info /= 0)) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = max(ix,idxmap%local_cols) +!!$ idxmap%loc_to_glob(ix) = idx(i) +!!$ idxmap%glob_to_loc(idx(i)) = ix +!!$ end if +!!$ idx(i) = ix +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end do +!!$ end if +!!$ +!!$ else if (.not.present(lidx)) then +!!$ +!!$ if (present(mask)) then +!!$ do i=1, is +!!$ if (mask(i)) then +!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ ix = idxmap%glob_to_loc(idx(i)) +!!$ if (ix < 0) then +!!$ ix = idxmap%local_cols + 1 +!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = ix +!!$ idxmap%loc_to_glob(ix) = idx(i) +!!$ idxmap%glob_to_loc(idx(i)) = ix +!!$ end if +!!$ idx(i) = ix +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end if +!!$ end do +!!$ +!!$ else if (.not.present(mask)) then +!!$ +!!$ do i=1, is +!!$ if ((1<= idx(i)).and.(idx(i) <= idxmap%global_rows)) then +!!$ ix = idxmap%glob_to_loc(idx(i)) +!!$ if (ix < 0) then +!!$ ix = idxmap%local_cols + 1 +!!$ call psb_ensure_size(ix,idxmap%loc_to_glob,info,addsz=laddsz) +!!$ if (info /= 0) then +!!$ info = -4 +!!$ return +!!$ end if +!!$ idxmap%local_cols = ix +!!$ idxmap%loc_to_glob(ix) = idx(i) +!!$ idxmap%glob_to_loc(idx(i)) = ix +!!$ end if +!!$ idx(i) = ix +!!$ else +!!$ idx(i) = -1 +!!$ end if +!!$ end do +!!$ end if +!!$ end if +!!$ +!!$ else +!!$ idx = -1 +!!$ info = -1 +!!$ end if +!!$ +!!$ end subroutine list_g2lv1_ins +!!$ +!!$ subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) +!!$ implicit none +!!$ class(psb_list_map), intent(inout) :: idxmap +!!$ integer(psb_ipk_), intent(in) :: idxin(:) +!!$ integer(psb_ipk_), intent(out) :: idxout(:) +!!$ integer(psb_ipk_), intent(out) :: info +!!$ logical, intent(in), optional :: mask(:) +!!$ integer(psb_ipk_), intent(in), optional :: lidx(:) +!!$ +!!$ integer(psb_ipk_) :: is, im +!!$ +!!$ is = size(idxin) +!!$ im = min(is,size(idxout)) +!!$ idxout(1:im) = idxin(1:im) +!!$ call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx) +!!$ if (is > im) info = -3 +!!$ +!!$ end subroutine list_g2lv2_ins +!!$ - subroutine list_g2ls1_ins(idx,idxmap,info,mask,lidx) + + subroutine list_lg2ls1_ins(idx,idxmap,info,mask,lidx) use psb_realloc_mod use psb_sort_mod implicit none class(psb_list_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx - integer(psb_ipk_) :: idxv(1), lidxv(1) + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) info = 0 if (present(mask)) then @@ -376,34 +838,49 @@ contains idx = idxv(1) - end subroutine list_g2ls1_ins + end subroutine list_lg2ls1_ins - subroutine list_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) + subroutine list_lg2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) implicit none class(psb_list_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx - idxout = idxin - call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + idxv(1) = idxin + if (present(lidx)) then + lidxv(1) = lidx + call idxmap%g2lip_ins(idxv,info,lidx=lidxv) + else + call idxmap%g2lip_ins(idxv,info) + end if + + idxout = idxv(1) - end subroutine list_g2ls2_ins + end subroutine list_lg2ls2_ins - subroutine list_g2lv1_ins(idx,idxmap,info,mask,lidx) + subroutine list_lg2lv1_ins(idx,idxmap,info,mask,lidx) use psb_realloc_mod use psb_sort_mod implicit none class(psb_list_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) - integer(psb_ipk_) :: i, is, ix, lix + integer(psb_ipk_) :: ix, lix + integer(psb_lpk_) :: i, is info = 0 is = size(idx) @@ -530,26 +1007,34 @@ contains info = -1 end if - end subroutine list_g2lv1_ins + end subroutine list_lg2lv1_ins - subroutine list_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) + subroutine list_lg2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) implicit none class(psb_list_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) - - integer(psb_ipk_) :: is, im + + integer(psb_lpk_) :: is, im + integer(psb_lpk_), allocatable :: idxv(:) is = size(idxin) im = min(is,size(idxout)) - idxout(1:im) = idxin(1:im) - call idxmap%g2lip_ins(idxout(1:im),info,mask=mask,lidx=lidx) + allocate(idxv(im),stat=info) + if (info /= 0) then + info = -5 + return + end if + + idxv(1:im) = idxin(1:im) + call idxmap%g2lip_ins(idxv(1:im),info,mask=mask,lidx=lidx) + idxout(1:im) = idxv(1:im) if (is > im) info = -3 - end subroutine list_g2lv2_ins + end subroutine list_lg2lv2_ins @@ -559,12 +1044,46 @@ contains use psb_error_mod implicit none class(psb_list_map), intent(inout) :: idxmap - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: vl(:) integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_ipk_) :: i, ix, nl, n, nrt - integer(psb_mpik_) :: iam, np + integer(psb_lpk_) :: nl + integer(psb_lpk_), allocatable :: lvl(:) + integer(psb_mpk_) :: iam, np + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + write(psb_err_unit,*) 'Invalid ictxt:',ictxt + info = -1 + return + end if + + nl = size(vl) + allocate(lvl(nl),stat=info) + if (info /= 0) then + info = -1 + return + end if + + lvl(1:nl) = vl(1:nl) + call idxmap%init_vl(ictxt,lvl,info) + + end subroutine list_initvl + + + subroutine list_initlvl(idxmap,ictxt,vl,info) + use psb_penv_mod + use psb_error_mod + implicit none + class(psb_list_map), intent(inout) :: idxmap + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_lpk_), intent(in) :: vl(:) + integer(psb_ipk_), intent(out) :: info + ! To be implemented + integer(psb_lpk_) :: i, ix, nl, n, nrt + integer(psb_mpk_) :: iam, np info = 0 call psb_info(ictxt,iam,np) @@ -615,7 +1134,7 @@ contains idxmap%local_cols = nl call idxmap%set_state(psb_desc_bld_) - end subroutine list_initvl + end subroutine list_initlvl subroutine list_asb(idxmap,info) @@ -628,7 +1147,7 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: nhal - integer(psb_mpik_) :: ictxt, iam, np + integer(psb_mpk_) :: ictxt, iam, np info = 0 ictxt = idxmap%get_ctxt() diff --git a/base/modules/desc/psb_repl_map_mod.f90 b/base/modules/desc/psb_repl_map_mod.f90 index 6a6225bd4..808878231 100644 --- a/base/modules/desc/psb_repl_map_mod.f90 +++ b/base/modules/desc/psb_repl_map_mod.f90 @@ -58,20 +58,20 @@ module psb_repl_map_mod procedure, pass(idxmap) :: reinit => repl_reinit procedure, nopass :: get_fmt => repl_get_fmt - procedure, pass(idxmap) :: l2gs1 => repl_l2gs1 - procedure, pass(idxmap) :: l2gs2 => repl_l2gs2 - procedure, pass(idxmap) :: l2gv1 => repl_l2gv1 - procedure, pass(idxmap) :: l2gv2 => repl_l2gv2 + procedure, pass(idxmap) :: ll2gs1 => repl_l2gs1 + procedure, pass(idxmap) :: ll2gs2 => repl_l2gs2 + procedure, pass(idxmap) :: ll2gv1 => repl_l2gv1 + procedure, pass(idxmap) :: ll2gv2 => repl_l2gv2 - procedure, pass(idxmap) :: g2ls1 => repl_g2ls1 - procedure, pass(idxmap) :: g2ls2 => repl_g2ls2 - procedure, pass(idxmap) :: g2lv1 => repl_g2lv1 - procedure, pass(idxmap) :: g2lv2 => repl_g2lv2 + procedure, pass(idxmap) :: lg2ls1 => repl_g2ls1 + procedure, pass(idxmap) :: lg2ls2 => repl_g2ls2 + procedure, pass(idxmap) :: lg2lv1 => repl_g2lv1 + procedure, pass(idxmap) :: lg2lv2 => repl_g2lv2 - procedure, pass(idxmap) :: g2ls1_ins => repl_g2ls1_ins - procedure, pass(idxmap) :: g2ls2_ins => repl_g2ls2_ins - procedure, pass(idxmap) :: g2lv1_ins => repl_g2lv1_ins - procedure, pass(idxmap) :: g2lv2_ins => repl_g2lv2_ins + procedure, pass(idxmap) :: lg2ls1_ins => repl_g2ls1_ins + procedure, pass(idxmap) :: lg2ls2_ins => repl_g2ls2_ins + procedure, pass(idxmap) :: lg2lv1_ins => repl_g2lv1_ins + procedure, pass(idxmap) :: lg2lv2_ins => repl_g2lv2_ins procedure, pass(idxmap) :: fnd_owner => repl_fnd_owner @@ -96,7 +96,7 @@ contains function repl_sizeof(idxmap) result(val) implicit none class(psb_repl_map), intent(in) :: idxmap - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = idxmap%psb_indx_map%sizeof() @@ -107,11 +107,11 @@ contains subroutine repl_l2gs1(idx,idxmap,info,mask,owned) implicit none class(psb_repl_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - integer(psb_ipk_) :: idxv(1) + integer(psb_lpk_) :: idxv(1) info = 0 if (present(mask)) then if (.not.mask) return @@ -127,13 +127,20 @@ contains implicit none class(psb_repl_map), intent(in) :: idxmap integer(psb_ipk_), intent(in) :: idxin - integer(psb_ipk_), intent(out) :: idxout + integer(psb_lpk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - idxout = idxin - call idxmap%l2gip(idxout,info,mask,owned) + integer(psb_lpk_) :: idxv(1) + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + + idxv(1) = idxin + call idxmap%l2gip(idxv,info,owned=owned) + idxout = idxv(1) end subroutine repl_l2gs2 @@ -141,11 +148,11 @@ contains subroutine repl_l2gv1(idx,idxmap,info,mask,owned) implicit none class(psb_repl_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: i + integer(psb_lpk_) :: i logical :: owned_ info = 0 @@ -191,12 +198,12 @@ contains implicit none class(psb_repl_map), intent(in) :: idxmap integer(psb_ipk_), intent(in) :: idxin(:) - integer(psb_ipk_), intent(out) :: idxout(:) + integer(psb_lpk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: is, im - integer(psb_ipk_) :: i + integer(psb_lpk_) :: is, im + integer(psb_lpk_) :: i logical :: owned_ info = 0 @@ -247,11 +254,11 @@ contains subroutine repl_g2ls1(idx,idxmap,info,mask,owned) implicit none class(psb_repl_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - integer(psb_ipk_) :: idxv(1) + integer(psb_lpk_) :: idxv(1) info = 0 if (present(mask)) then @@ -267,26 +274,35 @@ contains subroutine repl_g2ls2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_repl_map), intent(in) :: idxmap - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask logical, intent(in), optional :: owned - idxout = idxin - call idxmap%g2lip(idxout,info,mask,owned) + integer(psb_lpk_) :: idxv(1) + info = 0 + + if (present(mask)) then + if (.not.mask) return + end if - end subroutine repl_g2ls2 + idxv(1) = idxin + call idxmap%g2lip(idxv,info,owned=owned) + idxout = idxv(1) + + end subroutine repl_g2ls2 + subroutine repl_g2lv1(idx,idxmap,info,mask,owned) implicit none class(psb_repl_map), intent(in) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: i, is + integer(psb_lpk_) :: i, is logical :: owned_ info = 0 @@ -363,13 +379,13 @@ contains subroutine repl_g2lv2(idxin,idxout,idxmap,info,mask,owned) implicit none class(psb_repl_map), intent(in) :: idxmap - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) logical, intent(in), optional :: owned - integer(psb_ipk_) :: is, im,i + integer(psb_lpk_) :: is, im,i logical :: owned_ info = 0 @@ -453,12 +469,13 @@ contains use psb_sort_mod implicit none class(psb_repl_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(inout) :: idx + integer(psb_lpk_), intent(inout) :: idx integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx - integer(psb_ipk_) :: idxv(1),lidxv(1) + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) info = 0 if (present(mask)) then @@ -478,14 +495,27 @@ contains subroutine repl_g2ls2_ins(idxin,idxout,idxmap,info,mask,lidx) implicit none class(psb_repl_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: idxin + integer(psb_lpk_), intent(in) :: idxin integer(psb_ipk_), intent(out) :: idxout integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask integer(psb_ipk_), intent(in), optional :: lidx - - idxout = idxin - call idxmap%g2lip_ins(idxout,info,mask=mask,lidx=lidx) + integer(psb_lpk_) :: idxv(1) + integer(psb_ipk_) :: lidxv(1) + + info = 0 + if (present(mask)) then + if (.not.mask) return + end if + idxv(1) = idxin + if (present(lidx)) then + lidxv(1) = lidx + call idxmap%g2lip_ins(idxv,info,lidx=lidxv) + else + call idxmap%g2lip_ins(idxv,info) + end if + idxout = idxv(1) + end subroutine repl_g2ls2_ins @@ -495,12 +525,12 @@ contains use psb_sort_mod implicit none class(psb_repl_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(inout) :: idx(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) - integer(psb_ipk_) :: i, is + integer(psb_lpk_) :: i, is info = 0 is = size(idx) @@ -579,13 +609,13 @@ contains subroutine repl_g2lv2_ins(idxin,idxout,idxmap,info,mask,lidx) implicit none class(psb_repl_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: idxin(:) + integer(psb_lpk_), intent(in) :: idxin(:) integer(psb_ipk_), intent(out) :: idxout(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: mask(:) integer(psb_ipk_), intent(in), optional :: lidx(:) - integer(psb_ipk_) :: is, im, i + integer(psb_lpk_) :: is, im, i info = 0 @@ -669,12 +699,12 @@ contains subroutine repl_fnd_owner(idx,iprc,idxmap,info) use psb_penv_mod implicit none - integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_lpk_), intent(in) :: idx(:) integer(psb_ipk_), allocatable, intent(out) :: iprc(:) class(psb_repl_map), intent(in) :: idxmap integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: nv - integer(psb_mpik_) :: ictxt, iam, np + integer(psb_mpk_) :: ictxt, iam, np ictxt = idxmap%get_ctxt() call psb_info(ictxt,iam,np) @@ -695,11 +725,11 @@ contains use psb_error_mod implicit none class(psb_repl_map), intent(inout) :: idxmap - integer(psb_ipk_), intent(in) :: nl - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_lpk_), intent(in) :: nl + integer(psb_mpk_), intent(in) :: ictxt integer(psb_ipk_), intent(out) :: info ! To be implemented - integer(psb_mpik_) :: iam, np + integer(psb_mpk_) :: iam, np info = 0 call psb_info(ictxt,iam,np) @@ -729,7 +759,7 @@ contains class(psb_repl_map), intent(inout) :: idxmap integer(psb_ipk_), intent(out) :: info - integer(psb_mpik_) :: ictxt, iam, np + integer(psb_mpk_) :: ictxt, iam, np info = 0 ictxt = idxmap%get_ctxt() diff --git a/base/modules/error.f90 b/base/modules/error.f90 index fe8fea188..894118360 100644 --- a/base/modules/error.f90 +++ b/base/modules/error.f90 @@ -52,7 +52,7 @@ subroutine FCpsb_errpush(err_c, r_name, i_err) character(len=20), intent(in) :: r_name integer(psb_ipk_) :: i_err(5) - call psb_errpush(err_c, r_name, i_err) + call psb_errpush(err_c, r_name, i_err=i_err) end subroutine FCpsb_errpush diff --git a/base/modules/penv/psi_c_collective_mod.F90 b/base/modules/penv/psi_c_collective_mod.F90 new file mode 100644 index 000000000..2ae40807b --- /dev/null +++ b/base/modules/penv/psi_c_collective_mod.F90 @@ -0,0 +1,744 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_c_collective_mod + use psi_penv_mod + + + interface psb_sum + module procedure psb_csums, psb_csumv, psb_csumm, & + & psb_csums_ec, psb_csumv_ec, psb_csumm_ec + end interface + + interface psb_amx + module procedure psb_camxs, psb_camxv, psb_camxm, & + & psb_camxs_ec, psb_camxv_ec, psb_camxm_ec + end interface + + interface psb_amn + module procedure psb_camns, psb_camnv, psb_camnm, & + & psb_camns_ec, psb_camnv_ec, psb_camnm_ec + end interface + + + interface psb_bcast + module procedure psb_cbcasts, psb_cbcastv, psb_cbcastm, & + & psb_cbcasts_ec, psb_cbcastv_ec, psb_cbcastm_ec + end interface + + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Reduction operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + + ! + ! SUM + ! + + subroutine psb_csums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_csums + + subroutine psb_csumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_csumv + + subroutine psb_csumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_csumm + + subroutine psb_csums_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_csums_ec + + subroutine psb_csumv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_csumv_ec + + subroutine psb_csumm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_csumm_ec + + + ! + ! AMX: Maximum Absolute Value + ! + + subroutine psb_camxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_camxs + + subroutine psb_camxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_camxv + + subroutine psb_camxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_camxm + + + subroutine psb_camxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_camxs_ec + + subroutine psb_camxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_camxv_ec + + subroutine psb_camxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_camxm_ec + + + ! + ! AMN: Minimum Absolute Value + ! + + subroutine psb_camns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_camns + + subroutine psb_camnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_camnv + + subroutine psb_camnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_spk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_camnm + + + subroutine psb_camns_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_camns_ec + + subroutine psb_camnv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_camnv_ec + + subroutine psb_camnm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_camnm_ec + + + ! + ! BCAST Broadcast + ! + + subroutine psb_cbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call mpi_bcast(dat,1,psb_mpi_c_spk_,root_,ictxt,info) + +#endif + end subroutine psb_cbcasts + + subroutine psb_cbcastv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info) +#endif + end subroutine psb_cbcastv + + subroutine psb_cbcastm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info) +#endif + end subroutine psb_cbcastm + + + subroutine psb_cbcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_cbcasts_ec + + subroutine psb_cbcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_cbcastv_ec + + subroutine psb_cbcastm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_cbcastm_ec + + + +end module psi_c_collective_mod diff --git a/base/modules/penv/psi_c_p2p_mod.F90 b/base/modules/penv/psi_c_p2p_mod.F90 new file mode 100644 index 000000000..f732c8085 --- /dev/null +++ b/base/modules/penv/psi_c_p2p_mod.F90 @@ -0,0 +1,307 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psi_c_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_snd + module procedure psb_csnds, psb_csndv, psb_csndm, & + & psb_csnds_ec, psb_csndv_ec, psb_csndm_ec + end interface + + interface psb_rcv + module procedure psb_crcvs, psb_crcvv, psb_crcvm, & + & psb_crcvs_ec, psb_crcvv_ec, psb_crcvm_ec + end interface + +contains + + subroutine psb_csnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + complex(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_csnds + + subroutine psb_csndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:) + integer(psb_mpk_), intent(in) :: dst + complex(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_csndv + + subroutine psb_csndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:,:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_ipk_), intent(in), optional :: m + complex(psb_spk_), allocatable :: dat_(:) + integer(psb_ipk_) :: i,j,k,m_,n_ + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_csndm + + subroutine psb_crcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_crcvs + + subroutine psb_crcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat(:) + integer(psb_mpk_), intent(in) :: src + complex(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_crcvv + + subroutine psb_crcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat(:,:) + integer(psb_mpk_), intent(in) :: src + integer(psb_ipk_), intent(in), optional :: m + complex(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type + integer(psb_mpk_) :: i,j,k + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,psb_mpi_c_spk_,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_complex_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_crcvm + + + subroutine psb_csnds_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_csnds_ec + + subroutine psb_csndv_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_csndv_ec + + subroutine psb_csndm_ec(ictxt,dat,dst,m) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(in) :: dat(:,:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_csndm_ec + + subroutine psb_crcvs_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_crcvs_ec + + subroutine psb_crcvv_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat(:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_crcvv_ec + + subroutine psb_crcvm_ec(ictxt,dat,src,m) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_spk_), intent(out) :: dat(:,:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_crcvm_ec + + +end module psi_c_p2p_mod diff --git a/base/modules/penv/psi_collective_mod.F90 b/base/modules/penv/psi_collective_mod.F90 new file mode 100644 index 000000000..e382d6927 --- /dev/null +++ b/base/modules/penv/psi_collective_mod.F90 @@ -0,0 +1,420 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_collective_mod + use psi_penv_mod + use psi_m_collective_mod + use psi_e_collective_mod + use psi_s_collective_mod + use psi_d_collective_mod + use psi_c_collective_mod + use psi_z_collective_mod + + interface psb_bcast + module procedure psb_hbcasts, psb_hbcastv,& + & psb_hbcasts_ec, psb_hbcastv_ec,& + & psb_lbcasts, psb_lbcastv, & + & psb_lbcasts_ec, psb_lbcastv_ec + end interface psb_bcast + + +#if defined(SHORT_INTEGERS) + interface psb_sum + module procedure psb_i2sums, psb_i2sumv, psb_i2summ, & + & psb_i2sums_ec, psb_i2sumv_ec, psb_i2summ_ec + end interface psb_sum +#endif + +contains + + + subroutine psb_hbcasts(ictxt,dat,root,length) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + character(len=*), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root,length + + integer(psb_mpk_) :: iam, np, root_,length_,info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + if (present(length)) then + length_ = length + else + length_ = len(dat) + endif + + call psb_info(ictxt,iam,np) + + call mpi_bcast(dat,length_,MPI_CHARACTER,root_,ictxt,info) +#endif + + end subroutine psb_hbcasts + + subroutine psb_hbcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + character(len=*), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + + integer(psb_mpk_) :: iam, np, root_,length_,info, size_ + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + length_ = len(dat) + size_ = size(dat) + + call psb_info(ictxt,iam,np) + + call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,ictxt,info) +#endif + + end subroutine psb_hbcastv + + subroutine psb_hbcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + character(len=*), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_hbcasts_ec + + subroutine psb_hbcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + character(len=*), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_hbcastv_ec + + + + subroutine psb_lbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + + integer(psb_mpk_) :: iam, np, root_,info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,1,MPI_LOGICAL,root_,ictxt,info) +#endif + + end subroutine psb_lbcasts + + + subroutine psb_lbcastv(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + + integer(psb_mpk_) :: iam, np, root_,info + +#if !defined(SERIAL_MPI) + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call psb_info(ictxt,iam,np) + call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,ictxt,info) +#endif + + end subroutine psb_lbcastv + + + subroutine psb_lbcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + logical, intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_lbcasts_ec + + subroutine psb_lbcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + logical, intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_lbcastv_ec + + + +#if defined(SHORT_INTEGERS) + subroutine psb_i2sums(ictxt,dat,root) + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif + +#endif + end subroutine psb_i2sums + + subroutine psb_i2sumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_=dat + if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2sumv + + subroutine psb_i2summ(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_i2pk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_=dat + if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& + & psb_mpi_i2pk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_=dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + else + call mpi_reduce(dat,dat_,size(dat),psb_mpi_i2pk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_i2summ + + subroutine psb_i2sums_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_i2sums_ec + + subroutine psb_i2sumv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_i2sumv_ec + + subroutine psb_i2summ_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_i2pk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_i2summ_ec + +#endif + +end module psi_collective_mod diff --git a/base/modules/psi_comm_buffers_mod.F90 b/base/modules/penv/psi_comm_buffers_mod.F90 similarity index 72% rename from base/modules/psi_comm_buffers_mod.F90 rename to base/modules/penv/psi_comm_buffers_mod.F90 index fa86eea7f..c9c484e88 100644 --- a/base/modules/psi_comm_buffers_mod.F90 +++ b/base/modules/penv/psi_comm_buffers_mod.F90 @@ -33,20 +33,20 @@ ! Provide a fake mpi module just to keep the compiler(s) happy. module mpi use psb_const_mod - integer(psb_mpik_), parameter :: mpi_success = 0 - integer(psb_mpik_), parameter :: mpi_request_null = 0 - integer(psb_mpik_), parameter :: mpi_status_size = 1 - integer(psb_mpik_), parameter :: mpi_integer = 1 - integer(psb_mpik_), parameter :: mpi_integer8 = 2 - integer(psb_mpik_), parameter :: mpi_real = 3 - integer(psb_mpik_), parameter :: mpi_double_precision = 4 - integer(psb_mpik_), parameter :: mpi_complex = 5 - integer(psb_mpik_), parameter :: mpi_double_complex = 6 - integer(psb_mpik_), parameter :: mpi_character = 7 - integer(psb_mpik_), parameter :: mpi_logical = 8 - integer(psb_mpik_), parameter :: mpi_integer2 = 9 - integer(psb_mpik_), parameter :: mpi_comm_null = -1 - integer(psb_mpik_), parameter :: mpi_comm_world = 1 + integer(psb_mpk_), parameter :: mpi_success = 0 + integer(psb_mpk_), parameter :: mpi_request_null = 0 + integer(psb_mpk_), parameter :: mpi_status_size = 1 + integer(psb_mpk_), parameter :: mpi_integer = 1 + integer(psb_mpk_), parameter :: mpi_integer8 = 2 + integer(psb_mpk_), parameter :: mpi_real = 3 + integer(psb_mpk_), parameter :: mpi_double_precision = 4 + integer(psb_mpk_), parameter :: mpi_complex = 5 + integer(psb_mpk_), parameter :: mpi_double_complex = 6 + integer(psb_mpk_), parameter :: mpi_character = 7 + integer(psb_mpk_), parameter :: mpi_logical = 8 + integer(psb_mpk_), parameter :: mpi_integer2 = 9 + integer(psb_mpk_), parameter :: mpi_comm_null = -1 + integer(psb_mpk_), parameter :: mpi_comm_world = 1 real(psb_dpk_), external :: mpi_wtime end module mpi @@ -55,32 +55,58 @@ end module mpi module psi_comm_buffers_mod use psb_const_mod - integer(psb_mpik_), private, parameter:: psb_int_type = 987543 - integer(psb_mpik_), private, parameter:: psb_real_type = psb_int_type + 1 - integer(psb_mpik_), private, parameter:: psb_double_type = psb_real_type + 1 - integer(psb_mpik_), private, parameter:: psb_complex_type = psb_double_type + 1 - integer(psb_mpik_), private, parameter:: psb_dcomplex_type = psb_complex_type + 1 - integer(psb_mpik_), private, parameter:: psb_logical_type = psb_dcomplex_type + 1 - integer(psb_mpik_), private, parameter:: psb_char_type = psb_logical_type + 1 - integer(psb_mpik_), private, parameter:: psb_int8_type = psb_char_type + 1 - integer(psb_mpik_), private, parameter:: psb_int2_type = psb_int8_type + 1 - integer(psb_mpik_), private, parameter:: psb_int4_type = psb_int2_type + 1 + integer(psb_mpk_), parameter:: psb_int_tag = 543987 + integer(psb_mpk_), parameter:: psb_real_tag = psb_int_tag + 1 + integer(psb_mpk_), parameter:: psb_double_tag = psb_real_tag + 1 + integer(psb_mpk_), parameter:: psb_complex_tag = psb_double_tag + 1 + integer(psb_mpk_), parameter:: psb_dcomplex_tag = psb_complex_tag + 1 + integer(psb_mpk_), parameter:: psb_logical_tag = psb_dcomplex_tag + 1 + integer(psb_mpk_), parameter:: psb_char_tag = psb_logical_tag + 1 + integer(psb_mpk_), parameter:: psb_int8_tag = psb_char_tag + 1 + integer(psb_mpk_), parameter:: psb_int2_tag = psb_int8_tag + 1 + integer(psb_mpk_), parameter:: psb_int4_tag = psb_int2_tag + 1 + integer(psb_mpk_), parameter:: psb_long_tag = psb_int4_tag + 1 + + integer(psb_mpk_), parameter:: psb_int_swap_tag = psb_int_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_real_swap_tag = psb_real_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_double_swap_tag = psb_double_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_complex_swap_tag = psb_complex_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_dcomplex_swap_tag = psb_dcomplex_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_logical_swap_tag = psb_logical_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_char_swap_tag = psb_char_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_int8_swap_tag = psb_int8_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_int2_swap_tag = psb_int2_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_int4_swap_tag = psb_int4_tag + psb_int_tag + integer(psb_mpk_), parameter:: psb_long_swap_tag = psb_long_tag + psb_int_tag + + + + integer(psb_mpk_), private, parameter:: psb_int_type = 987543 + integer(psb_mpk_), private, parameter:: psb_real_type = psb_int_type + 1 + integer(psb_mpk_), private, parameter:: psb_double_type = psb_real_type + 1 + integer(psb_mpk_), private, parameter:: psb_complex_type = psb_double_type + 1 + integer(psb_mpk_), private, parameter:: psb_dcomplex_type = psb_complex_type + 1 + integer(psb_mpk_), private, parameter:: psb_logical_type = psb_dcomplex_type + 1 + integer(psb_mpk_), private, parameter:: psb_char_type = psb_logical_type + 1 + integer(psb_mpk_), private, parameter:: psb_int8_type = psb_char_type + 1 + integer(psb_mpk_), private, parameter:: psb_int2_type = psb_int8_type + 1 + integer(psb_mpk_), private, parameter:: psb_int4_type = psb_int2_type + 1 + integer(psb_mpk_), private, parameter:: psb_long_type = psb_int4_type + 1 type psb_buffer_node - integer(psb_mpik_) :: request - integer(psb_mpik_) :: icontxt - integer(psb_mpik_) :: buffer_type - integer(psb_ipk_), allocatable :: intbuf(:) - integer(psb_long_int_k_), allocatable :: int8buf(:) - integer(2), allocatable :: int2buf(:) - integer(psb_mpik_), allocatable :: int4buf(:) - real(psb_spk_), allocatable :: realbuf(:) - real(psb_dpk_), allocatable :: doublebuf(:) - complex(psb_spk_), allocatable :: complexbuf(:) - complex(psb_dpk_), allocatable :: dcomplbuf(:) - logical, allocatable :: logbuf(:) - character(len=1), allocatable :: charbuf(:) + integer(psb_mpk_) :: request + integer(psb_mpk_) :: icontxt + integer(psb_mpk_) :: buffer_type + integer(psb_epk_), allocatable :: int8buf(:) + integer(psb_i2pk_), allocatable :: int2buf(:) + integer(psb_mpk_), allocatable :: int4buf(:) + real(psb_spk_), allocatable :: realbuf(:) + real(psb_dpk_), allocatable :: doublebuf(:) + complex(psb_spk_), allocatable :: complexbuf(:) + complex(psb_dpk_), allocatable :: dcomplbuf(:) + logical, allocatable :: logbuf(:) + character(len=1), allocatable :: charbuf(:) type(psb_buffer_node), pointer :: prev=>null(), next=>null() end type psb_buffer_node @@ -90,29 +116,14 @@ module psi_comm_buffers_mod interface psi_snd - module procedure psi_isnd,& + module procedure& + & psi_msnd, psi_esnd,& & psi_ssnd, psi_dsnd,& & psi_csnd, psi_zsnd,& - & psi_lsnd, psi_hsnd + & psi_logsnd, psi_hsnd,& + & psi_i2snd end interface -#if defined(LONG_INTEGERS) - interface psi_snd - module procedure psi_i4snd - end interface -#endif -#if !defined(LONG_INTEGERS) - interface psi_snd - module procedure psi_i8snd - end interface -#endif - -#if defined(SHORT_INTEGERS) - interface psi_snd - module procedure psi_i2snd - end interface -#endif - contains subroutine psb_init_queue(mesg_queue,info) @@ -148,7 +159,7 @@ contains #endif type(psb_buffer_node), intent(inout) :: node integer(psb_ipk_), intent(out) :: info - integer(psb_mpik_) :: status(mpi_status_size),minfo + integer(psb_mpk_) :: status(mpi_status_size),minfo minfo = mpi_success call mpi_wait(node%request,status,minfo) info=minfo @@ -165,7 +176,7 @@ contains type(psb_buffer_node), intent(inout) :: node logical, intent(out) :: flag integer(psb_ipk_), intent(out) :: info - integer(psb_mpik_) :: status(mpi_status_size), minfo + integer(psb_mpk_) :: status(mpi_status_size), minfo minfo = mpi_success #if defined(SERIAL_MPI) flag = .true. @@ -178,7 +189,7 @@ contains subroutine psb_close_context(mesg_queue,icontxt) type(psb_buffer_queue), intent(inout) :: mesg_queue - integer(psb_mpik_), intent(in) :: icontxt + integer(psb_mpk_), intent(in) :: icontxt integer(psb_ipk_) :: info type(psb_buffer_node), pointer :: node, nextnode @@ -273,7 +284,7 @@ contains ! has already been copied. ! ! !!!!!!!!!!!!!!!!! - subroutine psi_isnd(icontxt,tag,dest,buffer,mesg_queue) + subroutine psi_msnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD use mpi #endif @@ -281,12 +292,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest - integer(psb_ipk_), allocatable, intent(inout) :: buffer(:) + integer(psb_mpk_) :: icontxt, tag, dest + integer(psb_mpk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then @@ -295,22 +306,22 @@ contains end if node%icontxt = icontxt node%buffer_type = psb_int_type - call move_alloc(buffer,node%intbuf) + call move_alloc(buffer,node%int4buf) if (info /= 0) then write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' return end if - call mpi_isend(node%intbuf,size(node%intbuf),psb_mpi_ipk_integer,& + call mpi_isend(node%int4buf,size(node%int4buf),psb_mpi_mpk_,& & dest,tag,icontxt,node%request,minfo) info = minfo call psb_insert_node(mesg_queue,node) call psb_test_nodes(mesg_queue) - end subroutine psi_isnd + end subroutine psi_msnd -#if defined(LONG_INTEGERS) - subroutine psi_i4snd(icontxt,tag,dest,buffer,mesg_queue) + + subroutine psi_esnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD use mpi #endif @@ -318,50 +329,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest - integer(psb_mpik_), allocatable, intent(inout) :: buffer(:) - type(psb_buffer_queue) :: mesg_queue - type(psb_buffer_node), pointer :: node - integer(psb_mpik_) :: info - integer(psb_mpik_) :: minfo - - allocate(node, stat=info) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - node%icontxt = icontxt - node%buffer_type = psb_int4_type - call move_alloc(buffer,node%int4buf) - if (info /= 0) then - write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' - return - end if - call mpi_isend(node%int4buf,size(node%int4buf),psb_mpi_def_integer,& - & dest,tag,icontxt,node%request,minfo) - info = minfo - call psb_insert_node(mesg_queue,node) - - call psb_test_nodes(mesg_queue) - - end subroutine psi_i4snd -#endif - -#if !defined(LONG_INTEGERS) - subroutine psi_i8snd(icontxt,tag,dest,buffer,mesg_queue) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_) :: icontxt, tag, dest - integer(psb_long_int_k_), allocatable, intent(inout) :: buffer(:) + integer(psb_mpk_) :: icontxt, tag, dest + integer(psb_epk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then @@ -375,17 +348,15 @@ contains write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' return end if - call mpi_isend(node%int8buf,size(node%int8buf),psb_mpi_lng_integer,& + call mpi_isend(node%int8buf,size(node%int8buf),psb_mpi_epk_,& & dest,tag,icontxt,node%request,minfo) info = minfo call psb_insert_node(mesg_queue,node) call psb_test_nodes(mesg_queue) - end subroutine psi_i8snd -#endif + end subroutine psi_esnd -#if defined(SHORT_INTEGERS) subroutine psi_i2snd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD use mpi @@ -394,12 +365,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest - integer(2), allocatable, intent(inout) :: buffer(:) + integer(psb_mpk_) :: icontxt, tag, dest + integer(psb_i2pk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then @@ -413,7 +384,7 @@ contains write(psb_err_unit,*) 'Fatal memory error inside communication subsystem' return end if - call mpi_isend(node%int2buf,size(node%int2buf),psb_mpi_def_integer2,& + call mpi_isend(node%int2buf,size(node%int2buf),psb_mpi_i2pk_,& & dest,tag,icontxt,node%request,minfo) info = minfo call psb_insert_node(mesg_queue,node) @@ -421,7 +392,6 @@ contains call psb_test_nodes(mesg_queue) end subroutine psi_i2snd -#endif subroutine psi_ssnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD @@ -431,12 +401,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest + integer(psb_mpk_) :: icontxt, tag, dest real(psb_spk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then @@ -467,12 +437,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest + integer(psb_mpk_) :: icontxt, tag, dest real(psb_dpk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then @@ -503,12 +473,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest + integer(psb_mpk_) :: icontxt, tag, dest complex(psb_spk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then @@ -539,12 +509,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest + integer(psb_mpk_) :: icontxt, tag, dest complex(psb_dpk_), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then @@ -568,7 +538,7 @@ contains end subroutine psi_zsnd - subroutine psi_lsnd(icontxt,tag,dest,buffer,mesg_queue) + subroutine psi_logsnd(icontxt,tag,dest,buffer,mesg_queue) #ifdef MPI_MOD use mpi #endif @@ -576,12 +546,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest + integer(psb_mpk_) :: icontxt, tag, dest logical, allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then @@ -602,7 +572,7 @@ contains call psb_test_nodes(mesg_queue) - end subroutine psi_lsnd + end subroutine psi_logsnd subroutine psi_hsnd(icontxt,tag,dest,buffer,mesg_queue) @@ -613,12 +583,12 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: icontxt, tag, dest + integer(psb_mpk_) :: icontxt, tag, dest character(len=1), allocatable, intent(inout) :: buffer(:) type(psb_buffer_queue) :: mesg_queue type(psb_buffer_node), pointer :: node integer(psb_ipk_) :: info - integer(psb_mpik_) :: minfo + integer(psb_mpk_) :: minfo allocate(node, stat=info) if (info /= 0) then diff --git a/base/modules/penv/psi_d_collective_mod.F90 b/base/modules/penv/psi_d_collective_mod.F90 new file mode 100644 index 000000000..537cf3a04 --- /dev/null +++ b/base/modules/penv/psi_d_collective_mod.F90 @@ -0,0 +1,1235 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_d_collective_mod + use psi_penv_mod + + interface psb_max + module procedure psb_dmaxs, psb_dmaxv, psb_dmaxm, & + & psb_dmaxs_ec, psb_dmaxv_ec, psb_dmaxm_ec + end interface + + interface psb_min + module procedure psb_dmins, psb_dminv, psb_dminm, & + & psb_dmins_ec, psb_dminv_ec, psb_dminm_ec + end interface psb_min + + interface psb_nrm2 + module procedure psb_d_nrm2s, psb_d_nrm2v, & + & psb_d_nrm2s_ec, psb_d_nrm2v_ec + end interface psb_nrm2 + + interface psb_sum + module procedure psb_dsums, psb_dsumv, psb_dsumm, & + & psb_dsums_ec, psb_dsumv_ec, psb_dsumm_ec + end interface + + interface psb_amx + module procedure psb_damxs, psb_damxv, psb_damxm, & + & psb_damxs_ec, psb_damxv_ec, psb_damxm_ec + end interface + + interface psb_amn + module procedure psb_damns, psb_damnv, psb_damnm, & + & psb_damns_ec, psb_damnv_ec, psb_damnm_ec + end interface + + + interface psb_bcast + module procedure psb_dbcasts, psb_dbcastv, psb_dbcastm, & + & psb_dbcasts_ec, psb_dbcastv_ec, psb_dbcastm_ec + end interface + + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Reduction operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! MAX + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_dmaxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_dmaxs + + subroutine psb_dmaxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dmaxv + + subroutine psb_dmaxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dmaxm + + + subroutine psb_dmaxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_dmaxs_ec + + subroutine psb_dmaxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_dmaxv_ec + + subroutine psb_dmaxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_dmaxm_ec + + + ! + ! MIN: Minimum Value + ! + + + subroutine psb_dmins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_dmins + + subroutine psb_dminv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dminv + + subroutine psb_dminm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dminm + + + subroutine psb_dmins_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_dmins_ec + + subroutine psb_dminv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_dminv_ec + + subroutine psb_dminm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_dminm_ec + + + + ! !!!!!!!!!!!! + ! + ! Norm 2, only for reals + ! + ! !!!!!!!!!!!! + subroutine psb_d_nrm2s(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_dnrm2_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_dnrm2_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_d_nrm2s + + subroutine psb_d_nrm2v(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& + & mpi_dnrm2_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& + & mpi_dnrm2_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,& + & mpi_dnrm2_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_d_nrm2v + + subroutine psb_d_nrm2s_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_nrm2(ictxt_,dat,root_) + else + call psb_nrm2(ictxt_,dat) + end if + end subroutine psb_d_nrm2s_ec + + subroutine psb_d_nrm2v_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_nrm2(ictxt_,dat,root_) + else + call psb_nrm2(ictxt_,dat) + end if + end subroutine psb_d_nrm2v_ec + + + ! + ! SUM + ! + + subroutine psb_dsums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_dsums + + subroutine psb_dsumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dsumv + + subroutine psb_dsumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_dsumm + + subroutine psb_dsums_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_dsums_ec + + subroutine psb_dsumv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_dsumv_ec + + subroutine psb_dsumm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_dsumm_ec + + + ! + ! AMX: Maximum Absolute Value + ! + + subroutine psb_damxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_damxs + + subroutine psb_damxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_damxv + + subroutine psb_damxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_damxm + + + subroutine psb_damxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_damxs_ec + + subroutine psb_damxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_damxv_ec + + subroutine psb_damxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_damxm_ec + + + ! + ! AMN: Minimum Absolute Value + ! + + subroutine psb_damns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_damns + + subroutine psb_damnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_damnv + + subroutine psb_damnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_dpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_damnm + + + subroutine psb_damns_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_damns_ec + + subroutine psb_damnv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_damnv_ec + + subroutine psb_damnm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_damnm_ec + + + ! + ! BCAST Broadcast + ! + + subroutine psb_dbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call mpi_bcast(dat,1,psb_mpi_r_dpk_,root_,ictxt,info) + +#endif + end subroutine psb_dbcasts + + subroutine psb_dbcastv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info) +#endif + end subroutine psb_dbcastv + + subroutine psb_dbcastm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info) +#endif + end subroutine psb_dbcastm + + + subroutine psb_dbcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_dbcasts_ec + + subroutine psb_dbcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_dbcastv_ec + + subroutine psb_dbcastm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_dbcastm_ec + + + +end module psi_d_collective_mod diff --git a/base/modules/penv/psi_d_p2p_mod.F90 b/base/modules/penv/psi_d_p2p_mod.F90 new file mode 100644 index 000000000..f59234f3b --- /dev/null +++ b/base/modules/penv/psi_d_p2p_mod.F90 @@ -0,0 +1,307 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psi_d_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_snd + module procedure psb_dsnds, psb_dsndv, psb_dsndm, & + & psb_dsnds_ec, psb_dsndv_ec, psb_dsndm_ec + end interface + + interface psb_rcv + module procedure psb_drcvs, psb_drcvv, psb_drcvm, & + & psb_drcvs_ec, psb_drcvv_ec, psb_drcvm_ec + end interface + +contains + + subroutine psb_dsnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_dsnds + + subroutine psb_dsndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:) + integer(psb_mpk_), intent(in) :: dst + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_dsndv + + subroutine psb_dsndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:,:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_ipk_), intent(in), optional :: m + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_ipk_) :: i,j,k,m_,n_ + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_dsndm + + subroutine psb_drcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_drcvs + + subroutine psb_drcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat(:) + integer(psb_mpk_), intent(in) :: src + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_drcvv + + subroutine psb_drcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat(:,:) + integer(psb_mpk_), intent(in) :: src + integer(psb_ipk_), intent(in), optional :: m + real(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type + integer(psb_mpk_) :: i,j,k + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,psb_mpi_r_dpk_,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_double_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_drcvm + + + subroutine psb_dsnds_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_dsnds_ec + + subroutine psb_dsndv_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_dsndv_ec + + subroutine psb_dsndm_ec(ictxt,dat,dst,m) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(in) :: dat(:,:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_dsndm_ec + + subroutine psb_drcvs_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_drcvs_ec + + subroutine psb_drcvv_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat(:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_drcvv_ec + + subroutine psb_drcvm_ec(ictxt,dat,src,m) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_dpk_), intent(out) :: dat(:,:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_drcvm_ec + + +end module psi_d_p2p_mod diff --git a/base/modules/penv/psi_e_collective_mod.F90 b/base/modules/penv/psi_e_collective_mod.F90 new file mode 100644 index 000000000..e00539155 --- /dev/null +++ b/base/modules/penv/psi_e_collective_mod.F90 @@ -0,0 +1,1112 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_e_collective_mod + use psi_penv_mod + + interface psb_max + module procedure psb_emaxs, psb_emaxv, psb_emaxm, & + & psb_emaxs_ec, psb_emaxv_ec, psb_emaxm_ec + end interface + + interface psb_min + module procedure psb_emins, psb_eminv, psb_eminm, & + & psb_emins_ec, psb_eminv_ec, psb_eminm_ec + end interface psb_min + + + interface psb_sum + module procedure psb_esums, psb_esumv, psb_esumm, & + & psb_esums_ec, psb_esumv_ec, psb_esumm_ec + end interface + + interface psb_amx + module procedure psb_eamxs, psb_eamxv, psb_eamxm, & + & psb_eamxs_ec, psb_eamxv_ec, psb_eamxm_ec + end interface + + interface psb_amn + module procedure psb_eamns, psb_eamnv, psb_eamnm, & + & psb_eamns_ec, psb_eamnv_ec, psb_eamnm_ec + end interface + + + interface psb_bcast + module procedure psb_ebcasts, psb_ebcastv, psb_ebcastm, & + & psb_ebcasts_ec, psb_ebcastv_ec, psb_ebcastm_ec + end interface + + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Reduction operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! MAX + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_emaxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_max,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_emaxs + + subroutine psb_emaxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_emaxv + + subroutine psb_emaxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_emaxm + + + subroutine psb_emaxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_emaxs_ec + + subroutine psb_emaxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_emaxv_ec + + subroutine psb_emaxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_emaxm_ec + + + ! + ! MIN: Minimum Value + ! + + + subroutine psb_emins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_min,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_emins + + subroutine psb_eminv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_eminv + + subroutine psb_eminm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_eminm + + + subroutine psb_emins_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_emins_ec + + subroutine psb_eminv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_eminv_ec + + subroutine psb_eminm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_eminm_ec + + + + + ! + ! SUM + ! + + subroutine psb_esums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_sum,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_esums + + subroutine psb_esumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_esumv + + subroutine psb_esumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_esumm + + subroutine psb_esums_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_esums_ec + + subroutine psb_esumv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_esumv_ec + + subroutine psb_esumm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_esumm_ec + + + ! + ! AMX: Maximum Absolute Value + ! + + subroutine psb_eamxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_eamx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_eamxs + + subroutine psb_eamxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_eamxv + + subroutine psb_eamxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_eamxm + + + subroutine psb_eamxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_eamxs_ec + + subroutine psb_eamxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_eamxv_ec + + subroutine psb_eamxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_eamxm_ec + + + ! + ! AMN: Minimum Absolute Value + ! + + subroutine psb_eamns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_epk_,mpi_eamn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_eamns + + subroutine psb_eamnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_eamnv + + subroutine psb_eamnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_epk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_epk_,mpi_eamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_eamnm + + + subroutine psb_eamns_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_eamns_ec + + subroutine psb_eamnv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_eamnv_ec + + subroutine psb_eamnm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_eamnm_ec + + + ! + ! BCAST Broadcast + ! + + subroutine psb_ebcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call mpi_bcast(dat,1,psb_mpi_epk_,root_,ictxt,info) + +#endif + end subroutine psb_ebcasts + + subroutine psb_ebcastv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_epk_,root_,ictxt,info) +#endif + end subroutine psb_ebcastv + + subroutine psb_ebcastm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_epk_,root_,ictxt,info) +#endif + end subroutine psb_ebcastm + + + subroutine psb_ebcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_ebcasts_ec + + subroutine psb_ebcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_ebcastv_ec + + subroutine psb_ebcastm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_ebcastm_ec + + + +end module psi_e_collective_mod diff --git a/base/modules/penv/psi_e_p2p_mod.F90 b/base/modules/penv/psi_e_p2p_mod.F90 new file mode 100644 index 000000000..d72f4ee0f --- /dev/null +++ b/base/modules/penv/psi_e_p2p_mod.F90 @@ -0,0 +1,307 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psi_e_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_snd + module procedure psb_esnds, psb_esndv, psb_esndm, & + & psb_esnds_ec, psb_esndv_ec, psb_esndm_ec + end interface + + interface psb_rcv + module procedure psb_ercvs, psb_ercvv, psb_ercvm, & + & psb_ercvs_ec, psb_ercvv_ec, psb_ercvm_ec + end interface + +contains + + subroutine psb_esnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_esnds + + subroutine psb_esndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(in) :: dat(:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_esndv + + subroutine psb_esndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(in) :: dat(:,:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_ipk_), intent(in), optional :: m + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_ipk_) :: i,j,k,m_,n_ + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_esndm + + subroutine psb_ercvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_ercvs + + subroutine psb_ercvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(out) :: dat(:) + integer(psb_mpk_), intent(in) :: src + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_ercvv + + subroutine psb_ercvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_epk_), intent(out) :: dat(:,:) + integer(psb_mpk_), intent(in) :: src + integer(psb_ipk_), intent(in), optional :: m + integer(psb_epk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type + integer(psb_mpk_) :: i,j,k + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,psb_mpi_epk_,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_int8_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),psb_mpi_epk_,src,psb_int8_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_ercvm + + + subroutine psb_esnds_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_esnds_ec + + subroutine psb_esndv_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(in) :: dat(:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_esndv_ec + + subroutine psb_esndm_ec(ictxt,dat,dst,m) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(in) :: dat(:,:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_esndm_ec + + subroutine psb_ercvs_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_ercvs_ec + + subroutine psb_ercvv_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(out) :: dat(:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_ercvv_ec + + subroutine psb_ercvm_ec(ictxt,dat,src,m) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(out) :: dat(:,:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_ercvm_ec + + +end module psi_e_p2p_mod diff --git a/base/modules/penv/psi_m_collective_mod.F90 b/base/modules/penv/psi_m_collective_mod.F90 new file mode 100644 index 000000000..d0ca82d7d --- /dev/null +++ b/base/modules/penv/psi_m_collective_mod.F90 @@ -0,0 +1,1112 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_m_collective_mod + use psi_penv_mod + + interface psb_max + module procedure psb_mmaxs, psb_mmaxv, psb_mmaxm, & + & psb_mmaxs_ec, psb_mmaxv_ec, psb_mmaxm_ec + end interface + + interface psb_min + module procedure psb_mmins, psb_mminv, psb_mminm, & + & psb_mmins_ec, psb_mminv_ec, psb_mminm_ec + end interface psb_min + + + interface psb_sum + module procedure psb_msums, psb_msumv, psb_msumm, & + & psb_msums_ec, psb_msumv_ec, psb_msumm_ec + end interface + + interface psb_amx + module procedure psb_mamxs, psb_mamxv, psb_mamxm, & + & psb_mamxs_ec, psb_mamxv_ec, psb_mamxm_ec + end interface + + interface psb_amn + module procedure psb_mamns, psb_mamnv, psb_mamnm, & + & psb_mamns_ec, psb_mamnv_ec, psb_mamnm_ec + end interface + + + interface psb_bcast + module procedure psb_mbcasts, psb_mbcastv, psb_mbcastm, & + & psb_mbcasts_ec, psb_mbcastv_ec, psb_mbcastm_ec + end interface + + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Reduction operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! MAX + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_mmaxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_max,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_mmaxs + + subroutine psb_mmaxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_mmaxv + + subroutine psb_mmaxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_mmaxm + + + subroutine psb_mmaxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_mmaxs_ec + + subroutine psb_mmaxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_mmaxv_ec + + subroutine psb_mmaxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_mmaxm_ec + + + ! + ! MIN: Minimum Value + ! + + + subroutine psb_mmins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_min,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_mmins + + subroutine psb_mminv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_mminv + + subroutine psb_mminm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_mminm + + + subroutine psb_mmins_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_mmins_ec + + subroutine psb_mminv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_mminv_ec + + subroutine psb_mminm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_mminm_ec + + + + + ! + ! SUM + ! + + subroutine psb_msums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_msums + + subroutine psb_msumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_msumv + + subroutine psb_msumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_msumm + + subroutine psb_msums_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_msums_ec + + subroutine psb_msumv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_msumv_ec + + subroutine psb_msumm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_msumm_ec + + + ! + ! AMX: Maximum Absolute Value + ! + + subroutine psb_mamxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_mamxs + + subroutine psb_mamxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_mamxv + + subroutine psb_mamxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_mamxm + + + subroutine psb_mamxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_mamxs_ec + + subroutine psb_mamxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_mamxv_ec + + subroutine psb_mamxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_mamxm_ec + + + ! + ! AMN: Minimum Absolute Value + ! + + subroutine psb_mamns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_mamns + + subroutine psb_mamnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_mamnv + + subroutine psb_mamnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_mpk_,mpi_mamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_mamnm + + + subroutine psb_mamns_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_mamns_ec + + subroutine psb_mamnv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_mamnv_ec + + subroutine psb_mamnm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_mamnm_ec + + + ! + ! BCAST Broadcast + ! + + subroutine psb_mbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call mpi_bcast(dat,1,psb_mpi_mpk_,root_,ictxt,info) + +#endif + end subroutine psb_mbcasts + + subroutine psb_mbcastv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_mpk_,root_,ictxt,info) +#endif + end subroutine psb_mbcastv + + subroutine psb_mbcastm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_mpk_,root_,ictxt,info) +#endif + end subroutine psb_mbcastm + + + subroutine psb_mbcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_mbcasts_ec + + subroutine psb_mbcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_mbcastv_ec + + subroutine psb_mbcastm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_mbcastm_ec + + + +end module psi_m_collective_mod diff --git a/base/modules/penv/psi_m_p2p_mod.F90 b/base/modules/penv/psi_m_p2p_mod.F90 new file mode 100644 index 000000000..f2600dc60 --- /dev/null +++ b/base/modules/penv/psi_m_p2p_mod.F90 @@ -0,0 +1,307 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psi_m_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_snd + module procedure psb_msnds, psb_msndv, psb_msndm, & + & psb_msnds_ec, psb_msndv_ec, psb_msndm_ec + end interface + + interface psb_rcv + module procedure psb_mrcvs, psb_mrcvv, psb_mrcvm, & + & psb_mrcvs_ec, psb_mrcvv_ec, psb_mrcvm_ec + end interface + +contains + + subroutine psb_msnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_msnds + + subroutine psb_msndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: dat(:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_msndv + + subroutine psb_msndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: dat(:,:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_ipk_), intent(in), optional :: m + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_ipk_) :: i,j,k,m_,n_ + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_msndm + + subroutine psb_mrcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_mrcvs + + subroutine psb_mrcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(out) :: dat(:) + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_mrcvv + + subroutine psb_mrcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(out) :: dat(:,:) + integer(psb_mpk_), intent(in) :: src + integer(psb_ipk_), intent(in), optional :: m + integer(psb_mpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type + integer(psb_mpk_) :: i,j,k + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,psb_mpi_mpk_,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_int4_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),psb_mpi_mpk_,src,psb_int4_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_mrcvm + + + subroutine psb_msnds_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_msnds_ec + + subroutine psb_msndv_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: dat(:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_msndv_ec + + subroutine psb_msndm_ec(ictxt,dat,dst,m) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: dat(:,:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_msndm_ec + + subroutine psb_mrcvs_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_mrcvs_ec + + subroutine psb_mrcvv_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(out) :: dat(:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_mrcvv_ec + + subroutine psb_mrcvm_ec(ictxt,dat,src,m) + + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_), intent(out) :: dat(:,:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_mrcvm_ec + + +end module psi_m_p2p_mod diff --git a/base/modules/penv/psi_p2p_mod.F90 b/base/modules/penv/psi_p2p_mod.F90 new file mode 100644 index 000000000..392344740 --- /dev/null +++ b/base/modules/penv/psi_p2p_mod.F90 @@ -0,0 +1,418 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psi_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + use psi_m_p2p_mod + use psi_e_p2p_mod + use psi_s_p2p_mod + use psi_d_p2p_mod + use psi_c_p2p_mod + use psi_z_p2p_mod + + + ! + ! Add here interfaces for + ! LOGICAL scalar/vector/matrix + ! CHARACTER scalar (use H prefix as in old style Hollerith) + ! + interface psb_snd + module procedure psb_lsnds, psb_lsndv, psb_lsndm,& + & psb_hsnds, psb_lsnds_ec, psb_lsndv_ec, & + & psb_lsndm_ec, psb_hsnds_ec + end interface + interface psb_rcv + module procedure psb_lrcvs, psb_lrcvv, psb_lrcvm,& + & psb_hrcvs, psb_lrcvs_ec, psb_lrcvv_ec, & + & psb_lrcvm_ec, psb_hrcvs_ec + end interface + + +contains + + + ! !!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Point-to-point SND + ! + ! !!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_lsnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + logical, allocatable :: dat_(:) + integer(psb_mpk_) :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_lsnds + + subroutine psb_lsndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(in) :: dat(:) + integer(psb_mpk_), intent(in) :: dst + logical, allocatable :: dat_(:) + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_lsndv + + subroutine psb_lsndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(in) :: dat(:,:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_ipk_), intent(in), optional :: m + logical, allocatable :: dat_(:) + integer(psb_mpk_) :: info + integer(psb_ipk_) :: i,j,k,m_,n_ + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_lsndm + + subroutine psb_hsnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + character(len=*), intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + character(len=1), allocatable :: dat_(:) + integer(psb_mpk_) :: info, l, i +#if defined(SERIAL_MPI) + ! do nothing +#else + l = len(dat) + allocate(dat_(l), stat=info) + do i=1, l + dat_(i) = dat(i:i) + end do + call psi_snd(ictxt,psb_char_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_hsnds + + subroutine psb_lsnds_ec(ictxt,dat,dst) + integer(psb_epk_), intent(in) :: ictxt + logical, intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_lsnds_ec + + subroutine psb_lsndv_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + logical, intent(in) :: dat(:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_lsndv_ec + + subroutine psb_lsndm_ec(ictxt,dat,dst,m) + + integer(psb_epk_), intent(in) :: ictxt + logical, intent(in) :: dat(:,:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_lsndm_ec + + + subroutine psb_hsnds_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + character(len=*), intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_hsnds_ec + + + ! !!!!!!!!!!!!!!!!!!!!!!!! + ! + ! Point-to-point RCV + ! + ! !!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_lrcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,mpi_logical,src,psb_logical_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_lrcvs + + subroutine psb_lrcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(out) :: dat(:) + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),mpi_logical,src,psb_logical_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_lrcvv + + subroutine psb_lrcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + logical, intent(out) :: dat(:,:) + integer(psb_mpk_), intent(in) :: src + integer(psb_ipk_), intent(in), optional :: m + integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type + integer(psb_ipk_) :: i,j,k + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,mpi_logical,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_logical_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),mpi_logical,src,& + & psb_logical_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_lrcvm + + + subroutine psb_hrcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + character(len=*), intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + character(len=1), allocatable :: dat_(:) + integer(psb_mpk_) :: info, l, i + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + l = len(dat) + allocate(dat_(l), stat=info) + call mpi_recv(dat_,l,mpi_character,src,psb_char_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) + do i=1, l + dat(i:i) = dat_(i) + end do + deallocate(dat_) +#endif + end subroutine psb_hrcvs + + + subroutine psb_lrcvs_ec(ictxt,dat,src) + integer(psb_epk_), intent(in) :: ictxt + logical, intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_lrcvs_ec + + subroutine psb_lrcvv_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + logical, intent(out) :: dat(:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_lrcvv_ec + + subroutine psb_lrcvm_ec(ictxt,dat,src,m) + + integer(psb_epk_), intent(in) :: ictxt + logical, intent(out) :: dat(:,:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_lrcvm_ec + + + subroutine psb_hrcvs_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + character(len=*), intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_hrcvs_ec + +end module psi_p2p_mod diff --git a/base/modules/psi_penv_mod.F90 b/base/modules/penv/psi_penv_mod.F90 similarity index 72% rename from base/modules/psi_penv_mod.F90 rename to base/modules/penv/psi_penv_mod.F90 index 5b4c53e75..b4feabb4b 100644 --- a/base/modules/psi_penv_mod.F90 +++ b/base/modules/penv/psi_penv_mod.F90 @@ -53,47 +53,44 @@ module psi_penv_mod module procedure psb_barrier_mpik end interface -#if defined(LONG_INTEGERS) interface psb_init - module procedure psb_init_ipk + module procedure psb_init_epk end interface interface psb_exit - module procedure psb_exit_ipk + module procedure psb_exit_epk end interface interface psb_abort - module procedure psb_abort_ipk + module procedure psb_abort_epk end interface interface psb_info - module procedure psb_info_ipk + module procedure psb_info_epk end interface interface psb_barrier - module procedure psb_barrier_ipk + module procedure psb_barrier_epk end interface -#endif - interface psb_wtime module procedure psb_wtime end interface #if defined(SERIAL_MPI) - integer(psb_mpik_), private, save :: nctxt=0 + integer(psb_mpk_), private, save :: nctxt=0 #else - integer(psb_mpik_), save :: mpi_iamx_op, mpi_iamn_op - integer(psb_mpik_), save :: mpi_i4amx_op, mpi_i4amn_op - integer(psb_mpik_), save :: mpi_i8amx_op, mpi_i8amn_op - integer(psb_mpik_), save :: mpi_samx_op, mpi_samn_op - integer(psb_mpik_), save :: mpi_damx_op, mpi_damn_op - integer(psb_mpik_), save :: mpi_camx_op, mpi_camn_op - integer(psb_mpik_), save :: mpi_zamx_op, mpi_zamn_op - integer(psb_mpik_), save :: mpi_snrm2_op, mpi_dnrm2_op + integer(psb_mpk_), save :: mpi_iamx_op, mpi_iamn_op + integer(psb_mpk_), save :: mpi_mamx_op, mpi_mamn_op + integer(psb_mpk_), save :: mpi_eamx_op, mpi_eamn_op + integer(psb_mpk_), save :: mpi_samx_op, mpi_samn_op + integer(psb_mpk_), save :: mpi_damx_op, mpi_damn_op + integer(psb_mpk_), save :: mpi_camx_op, mpi_camn_op + integer(psb_mpk_), save :: mpi_zamx_op, mpi_zamn_op + integer(psb_mpk_), save :: mpi_snrm2_op, mpi_dnrm2_op type(psb_buffer_queue), save :: psb_mesg_queue @@ -101,8 +98,8 @@ module psi_penv_mod private :: psi_get_sizes, psi_register_mpi_extras private :: psi_iamx_op, psi_iamn_op - private :: psi_i4amx_op, psi_i4amn_op - private :: psi_i8amx_op, psi_i8amn_op + private :: psi_mamx_op, psi_mamn_op + private :: psi_eamx_op, psi_eamn_op private :: psi_samx_op, psi_samn_op private :: psi_damx_op, psi_damn_op private :: psi_camx_op, psi_camn_op @@ -121,13 +118,19 @@ contains use psb_const_mod real(psb_dpk_) :: dv(2) real(psb_spk_) :: sv(2) + integer(psb_i2pk_):: i2v(2) + integer(psb_mpk_) :: mv(2) integer(psb_ipk_) :: iv(2) - integer(psb_long_int_k_) :: ilv(2) + integer(psb_lpk_) :: lv(2) + integer(psb_epk_) :: ev(2) call psi_c_diffadd(sv(1),sv(2),psb_sizeof_sp) call psi_c_diffadd(dv(1),dv(2),psb_sizeof_dp) - call psi_c_diffadd(iv(1),iv(2),psb_sizeof_int) - call psi_c_diffadd(ilv(1),ilv(2),psb_sizeof_long_int) + call psi_c_diffadd(i2v(1),i2v(2),psb_sizeof_i2p) + call psi_c_diffadd(mv(1),mv(2),psb_sizeof_mp) + call psi_c_diffadd(iv(1),iv(2),psb_sizeof_ip) + call psi_c_diffadd(lv(1),lv(2),psb_sizeof_lp) + call psi_c_diffadd(ev(1),ev(2),psb_sizeof_ep) end subroutine psi_get_sizes @@ -139,39 +142,50 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_) :: info + integer(psb_mpk_) :: info info = 0 #if 0 - if (info == 0) call mpi_type_create_f90_integer(psb_ipk_, psb_mpi_ipk_integer ,info) - if (info == 0) call mpi_type_create_f90_integer(psb_mpik_, psb_mpi_def_integer ,info) - if (info == 0) call mpi_type_create_f90_integer(psb_long_int_k_, psb_mpi_lng_integer ,info) + if (info == 0) call mpi_type_create_f90_integer(psb_ipk_, psb_mpi_ipk_ ,info) + if (info == 0) call mpi_type_create_f90_integer(psb_lpk_, psb_mpi_lpk_ ,info) + if (info == 0) call mpi_type_create_f90_integer(psb_mpk_, psb_mpi_mpk_ ,info) + if (info == 0) call mpi_type_create_f90_integer(psb_epk_, psb_mpi_lpk_ ,info) if (info == 0) call mpi_type_create_f90_real(psb_spk_p_,psb_spk_r_, psb_mpi_r_spk_,info) if (info == 0) call mpi_type_create_f90_real(psb_dpk_p_,psb_dpk_r_, psb_mpi_r_dpk_,info) if (info == 0) call mpi_type_create_f90_complex(psb_spk_p_,psb_spk_r_, psb_mpi_c_spk_,info) if (info == 0) call mpi_type_create_f90_complex(psb_dpk_p_,psb_dpk_r_, psb_mpi_c_dpk_,info) #else -#if defined(LONG_INTEGERS) - psb_mpi_ipk_integer = mpi_integer8 +#if defined(IPK4) && defined(LPK4) + psb_mpi_ipk_ = mpi_integer4 + psb_mpi_lpk_ = mpi_integer4 +#elif defined(IPK4) && defined(LPK8) + psb_mpi_ipk_ = mpi_integer4 + psb_mpi_lpk_ = mpi_integer8 +#elif defined(IPK8) && defined(LPK8) + psb_mpi_ipk_ = mpi_integer8 + psb_mpi_lpk_ = mpi_integer8 #else - psb_mpi_ipk_integer = mpi_integer + ! This should never happen + write(psb_err_unit,*) 'Warning: an impossible IPK/LPK combination.' + write(psb_err_unit,*) 'Something went wrong at configuration time.' + psb_mpi_ipk_ = -1 + psb_mpi_lpk_ = -1 #endif - psb_mpi_def_integer = mpi_integer - psb_mpi_lng_integer = mpi_integer8 - psb_mpi_r_spk_ = mpi_real - psb_mpi_r_dpk_ = mpi_double_precision - psb_mpi_c_spk_ = mpi_complex - psb_mpi_c_dpk_ = mpi_double_complex + psb_mpi_i2pk_ = mpi_integer2 + psb_mpi_mpk_ = mpi_integer4 + psb_mpi_epk_ = mpi_integer8 + psb_mpi_r_spk_ = mpi_real + psb_mpi_r_dpk_ = mpi_double_precision + psb_mpi_c_spk_ = mpi_complex + psb_mpi_c_dpk_ = mpi_double_complex #endif #if defined(SERIAL_MPI) #else - if (info == 0) call mpi_op_create(psi_iamx_op,.true.,mpi_iamx_op,info) - if (info == 0) call mpi_op_create(psi_iamn_op,.true.,mpi_iamn_op,info) - if (info == 0) call mpi_op_create(psi_i4amx_op,.true.,mpi_i4amx_op,info) - if (info == 0) call mpi_op_create(psi_i4amn_op,.true.,mpi_i4amn_op,info) - if (info == 0) call mpi_op_create(psi_i8amx_op,.true.,mpi_i8amx_op,info) - if (info == 0) call mpi_op_create(psi_i8amn_op,.true.,mpi_i8amn_op,info) + if (info == 0) call mpi_op_create(psi_mamx_op,.true.,mpi_mamx_op,info) + if (info == 0) call mpi_op_create(psi_mamn_op,.true.,mpi_mamn_op,info) + if (info == 0) call mpi_op_create(psi_eamx_op,.true.,mpi_eamx_op,info) + if (info == 0) call mpi_op_create(psi_eamn_op,.true.,mpi_eamn_op,info) if (info == 0) call mpi_op_create(psi_samx_op,.true.,mpi_samx_op,info) if (info == 0) call mpi_op_create(psi_samn_op,.true.,mpi_samn_op,info) if (info == 0) call mpi_op_create(psi_damx_op,.true.,mpi_damx_op,info) @@ -186,14 +200,13 @@ contains end subroutine psi_register_mpi_extras -#if defined(LONG_INTEGERS) - subroutine psb_init_ipk(ictxt,np,basectxt,ids) - integer(psb_ipk_), intent(out) :: ictxt - integer(psb_ipk_), intent(in), optional :: np, basectxt, ids(:) + subroutine psb_init_epk(ictxt,np,basectxt,ids) + integer(psb_epk_), intent(out) :: ictxt + integer(psb_epk_), intent(in), optional :: np, basectxt, ids(:) - integer(psb_mpik_) :: iictxt - integer(psb_mpik_) :: inp, ibasectxt - integer(psb_mpik_), allocatable :: ids_(:) + integer(psb_mpk_) :: iictxt + integer(psb_mpk_) :: inp, ibasectxt + integer(psb_mpk_), allocatable :: ids_(:) if (present(ids)) then allocate(ids_(size(ids))) @@ -215,29 +228,29 @@ contains call psb_init(iictxt,ids=ids_) end if ictxt = iictxt - end subroutine psb_init_ipk + end subroutine psb_init_epk - subroutine psb_exit_ipk(ictxt,close) - integer(psb_ipk_), intent(inout) :: ictxt + subroutine psb_exit_epk(ictxt,close) + integer(psb_epk_), intent(inout) :: ictxt logical, intent(in), optional :: close - integer(psb_mpik_) :: iictxt + integer(psb_mpk_) :: iictxt iictxt = ictxt call psb_exit(iictxt, close) - end subroutine psb_exit_ipk + end subroutine psb_exit_epk - subroutine psb_barrier_ipk(ictxt) - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_mpik_) :: iictxt + subroutine psb_barrier_epk(ictxt) + integer(psb_epk_), intent(in) :: ictxt + integer(psb_mpk_) :: iictxt iictxt = ictxt call psb_barrier(iictxt) - end subroutine psb_barrier_ipk + end subroutine psb_barrier_epk - subroutine psb_abort_ipk(ictxt,errc) - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(in), optional :: errc - integer(psb_mpik_) :: iictxt, ierrc + subroutine psb_abort_epk(ictxt,errc) + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(in), optional :: errc + integer(psb_mpk_) :: iictxt, ierrc iictxt = ictxt if (present(errc)) then @@ -246,29 +259,26 @@ contains else call psb_abort(iictxt) end if - end subroutine psb_abort_ipk + end subroutine psb_abort_epk - subroutine psb_info_ipk(ictxt,iam,np) + subroutine psb_info_epk(ictxt,iam,np) - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: iam, np + integer(psb_epk_), intent(in) :: ictxt + integer(psb_epk_), intent(out) :: iam, np ! ! Simple caching scheme, keep track ! of the last CTXT encountered. ! - integer(psb_mpik_), save :: lctxt=-1, lam, lnp + integer(psb_mpk_), save :: lctxt=-1, lam, lnp if (ictxt /= lctxt) then lctxt = ictxt call psb_info(lctxt,lam,lnp) end if iam = lam np = lnp - end subroutine psb_info_ipk + end subroutine psb_info_epk - -#endif - subroutine psb_init_mpik(ictxt,np,basectxt,ids) use psi_comm_buffers_mod use psb_const_mod @@ -283,13 +293,13 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_), intent(out) :: ictxt - integer(psb_mpik_), intent(in), optional :: np, basectxt, ids(:) + integer(psb_mpk_), intent(out) :: ictxt + integer(psb_mpk_), intent(in), optional :: np, basectxt, ids(:) - integer(psb_mpik_) :: i, isnullcomm - integer(psb_mpik_), allocatable :: iids(:) + integer(psb_mpk_) :: i, isnullcomm + integer(psb_mpk_), allocatable :: iids(:) logical :: initialized - integer(psb_mpik_) :: np_, npavail, iam, info, basecomm, basegroup, newgroup + integer(psb_mpk_) :: np_, npavail, iam, info, basecomm, basegroup, newgroup character(len=20), parameter :: name='psb_init' integer(psb_ipk_) :: iinfo ! @@ -409,10 +419,10 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_), intent(inout) :: ictxt + integer(psb_mpk_), intent(inout) :: ictxt logical, intent(in), optional :: close logical :: close_ - integer(psb_mpik_) :: info + integer(psb_mpk_) :: info character(len=20), parameter :: name='psb_exit' info = 0 @@ -460,9 +470,9 @@ contains #ifdef MPI_H include 'mpif.h' #endif - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_mpk_), intent(in) :: ictxt - integer(psb_mpik_) :: info + integer(psb_mpk_) :: info #if !defined(SERIAL_MPI) if (ictxt /= mpi_comm_null) then call mpi_barrier(ictxt, info) @@ -489,10 +499,10 @@ contains subroutine psb_abort_mpik(ictxt,errc) use psi_comm_buffers_mod - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(in), optional :: errc + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(in), optional :: errc - integer(psb_mpik_) :: code, info + integer(psb_mpk_) :: code, info #if defined(SERIAL_MPI) stop @@ -519,14 +529,14 @@ contains include 'mpif.h' #endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(out) :: iam, np - integer(psb_mpik_) :: info + integer(psb_mpk_), intent(in) :: ictxt + integer(psb_mpk_), intent(out) :: iam, np + integer(psb_mpk_) :: info ! ! Simple caching scheme, keep track ! of the last CTXT encountered. ! - integer(psb_mpik_), save :: lctxt=-1, lam, lnp + integer(psb_mpk_), save :: lctxt=-1, lam, lnp #if defined(SERIAL_MPI) iam = 0 @@ -554,13 +564,13 @@ contains subroutine psb_get_mpicomm(ictxt,comm) - integer(psb_mpik_) :: ictxt, comm + integer(psb_mpk_) :: ictxt, comm comm = ictxt end subroutine psb_get_mpicomm subroutine psb_get_rank(rank,ictxt,id) - integer(psb_mpik_) :: rank,ictxt,id + integer(psb_mpk_) :: rank,ictxt,id rank = id end subroutine psb_get_rank @@ -573,148 +583,129 @@ contains ! Note: len & type are always default integer. ! ! !!!!!!!!!!!!!!!!!!!!!! - subroutine psi_iamx_op(inv, outv,len,type) - integer(psb_ipk_) :: inv(*),outv(*) - integer(psb_mpik_) :: len,type - integer(psb_mpik_) :: i + subroutine psi_mamx_op(inv, outv,len,type) + integer(psb_mpk_) :: inv(*),outv(*) + integer(psb_mpk_) :: len,type + integer(psb_mpk_) :: i do i=1, len if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i) end do - end subroutine psi_iamx_op + end subroutine psi_mamx_op + + subroutine psi_mamn_op(inv, outv,len,type) + integer(psb_mpk_) :: inv(*),outv(*) + integer(psb_mpk_) :: len,type + integer(psb_mpk_) :: i - subroutine psi_iamn_op(inv, outv,len,type) - integer(psb_ipk_) :: inv(*),outv(*) - integer(psb_mpik_) :: len,type - integer(psb_mpik_) :: i do i=1, len if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i) end do - end subroutine psi_iamn_op + end subroutine psi_mamn_op - subroutine psi_i4amx_op(inv, outv,len,type) - integer(psb_mpik_) :: inv(*),outv(*) - integer(psb_mpik_) :: len,type - integer(psb_mpik_) :: i + subroutine psi_eamx_op(inv, outv,len,type) + integer(psb_epk_) :: inv(*),outv(*) + integer(psb_mpk_) :: len,type + integer(psb_mpk_) :: i do i=1, len if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i) end do - end subroutine psi_i4amx_op + end subroutine psi_eamx_op - subroutine psi_i4amn_op(inv, outv,len,type) - integer(psb_mpik_) :: inv(*),outv(*) - integer(psb_mpik_) :: len,type - integer(psb_mpik_) :: i + subroutine psi_eamn_op(inv, outv,len,type) + integer(psb_epk_) :: inv(*),outv(*) + integer(psb_mpk_) :: len,type + integer(psb_mpk_) :: i do i=1, len if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i) end do - end subroutine psi_i4amn_op - - subroutine psi_i8amx_op(inv, outv,len,type) - integer(psb_long_int_k_) :: inv(*),outv(*) - integer(psb_mpik_) :: len,type - integer(psb_mpik_) :: i - - do i=1, len - if (abs(inv(i)) > abs(outv(i))) outv(i) = inv(i) - end do - end subroutine psi_i8amx_op - - subroutine psi_i8amn_op(inv, outv,len,type) - integer(psb_long_int_k_) :: inv(*),outv(*) - integer(psb_mpik_) :: len,type - integer(psb_mpik_) :: i - - do i=1, len - if (abs(inv(i)) < abs(outv(i))) outv(i) = inv(i) - end do - end subroutine psi_i8amn_op + end subroutine psi_eamn_op subroutine psi_samx_op(vin,vinout,len,itype) - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype real(psb_spk_), intent(in) :: vin(len) real(psb_spk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i do i=1, len if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i) end do end subroutine psi_samx_op subroutine psi_samn_op(vin,vinout,len,itype) - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype real(psb_spk_), intent(in) :: vin(len) real(psb_spk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i do i=1, len if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i) end do end subroutine psi_samn_op subroutine psi_damx_op(vin,vinout,len,itype) - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype real(psb_dpk_), intent(in) :: vin(len) real(psb_dpk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i do i=1, len if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i) end do end subroutine psi_damx_op subroutine psi_damn_op(vin,vinout,len,itype) - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype real(psb_dpk_), intent(in) :: vin(len) real(psb_dpk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i do i=1, len if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i) end do end subroutine psi_damn_op subroutine psi_camx_op(vin,vinout,len,itype) - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype complex(psb_spk_), intent(in) :: vin(len) complex(psb_spk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i do i=1, len if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i) end do end subroutine psi_camx_op subroutine psi_camn_op(vin,vinout,len,itype) - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype complex(psb_spk_), intent(in) :: vin(len) complex(psb_spk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i do i=1, len if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i) end do end subroutine psi_camn_op subroutine psi_zamx_op(vin,vinout,len,itype) - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype complex(psb_dpk_), intent(in) :: vin(len) complex(psb_dpk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i do i=1, len if (abs(vinout(i)) < abs(vin(i))) vinout(i) = vin(i) end do end subroutine psi_zamx_op subroutine psi_zamn_op(vin,vinout,len,itype) - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype complex(psb_dpk_), intent(in) :: vin(len) complex(psb_dpk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i do i=1, len if (abs(vinout(i)) > abs(vin(i))) vinout(i) = vin(i) end do @@ -722,11 +713,11 @@ contains subroutine psi_snrm2_op(vin,vinout,len,itype) implicit none - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype real(psb_spk_), intent(in) :: vin(len) real(psb_spk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i real(psb_spk_) :: w, z do i=1, len w = max( vin(i), vinout(i) ) @@ -741,11 +732,11 @@ contains subroutine psi_dnrm2_op(vin,vinout,len,itype) implicit none - integer(psb_mpik_), intent(in) :: len, itype + integer(psb_mpk_), intent(in) :: len, itype real(psb_dpk_), intent(in) :: vin(len) real(psb_dpk_), intent(inout) :: vinout(len) - integer(psb_mpik_) :: i + integer(psb_mpk_) :: i real(psb_dpk_) :: w, z do i=1, len w = max( vin(i), vinout(i) ) diff --git a/base/modules/penv/psi_s_collective_mod.F90 b/base/modules/penv/psi_s_collective_mod.F90 new file mode 100644 index 000000000..0c985f2dd --- /dev/null +++ b/base/modules/penv/psi_s_collective_mod.F90 @@ -0,0 +1,1235 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_s_collective_mod + use psi_penv_mod + + interface psb_max + module procedure psb_smaxs, psb_smaxv, psb_smaxm, & + & psb_smaxs_ec, psb_smaxv_ec, psb_smaxm_ec + end interface + + interface psb_min + module procedure psb_smins, psb_sminv, psb_sminm, & + & psb_smins_ec, psb_sminv_ec, psb_sminm_ec + end interface psb_min + + interface psb_nrm2 + module procedure psb_s_nrm2s, psb_s_nrm2v, & + & psb_s_nrm2s_ec, psb_s_nrm2v_ec + end interface psb_nrm2 + + interface psb_sum + module procedure psb_ssums, psb_ssumv, psb_ssumm, & + & psb_ssums_ec, psb_ssumv_ec, psb_ssumm_ec + end interface + + interface psb_amx + module procedure psb_samxs, psb_samxv, psb_samxm, & + & psb_samxs_ec, psb_samxv_ec, psb_samxm_ec + end interface + + interface psb_amn + module procedure psb_samns, psb_samnv, psb_samnm, & + & psb_samns_ec, psb_samnv_ec, psb_samnm_ec + end interface + + + interface psb_bcast + module procedure psb_sbcasts, psb_sbcastv, psb_sbcastm, & + & psb_sbcasts_ec, psb_sbcastv_ec, psb_sbcastm_ec + end interface + + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Reduction operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! MAX + ! + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine psb_smaxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_max,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_smaxs + + subroutine psb_smaxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_smaxv + + subroutine psb_smaxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_smaxm + + + subroutine psb_smaxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_smaxs_ec + + subroutine psb_smaxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_smaxv_ec + + subroutine psb_smaxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_max(ictxt_,dat,root_) + else + call psb_max(ictxt_,dat) + end if + end subroutine psb_smaxm_ec + + + ! + ! MIN: Minimum Value + ! + + + subroutine psb_smins(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_min,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_smins + + subroutine psb_sminv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_sminv + + subroutine psb_sminm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_sminm + + + subroutine psb_smins_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_smins_ec + + subroutine psb_sminv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_sminv_ec + + subroutine psb_sminm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_min(ictxt_,dat,root_) + else + call psb_min(ictxt_,dat) + end if + end subroutine psb_sminm_ec + + + + ! !!!!!!!!!!!! + ! + ! Norm 2, only for reals + ! + ! !!!!!!!!!!!! + subroutine psb_s_nrm2s(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_snrm2_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_snrm2_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_s_nrm2s + + subroutine psb_s_nrm2v(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,& + & mpi_snrm2_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,& + & mpi_snrm2_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,& + & mpi_snrm2_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_s_nrm2v + + subroutine psb_s_nrm2s_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_nrm2(ictxt_,dat,root_) + else + call psb_nrm2(ictxt_,dat) + end if + end subroutine psb_s_nrm2s_ec + + subroutine psb_s_nrm2v_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_nrm2(ictxt_,dat,root_) + else + call psb_nrm2(ictxt_,dat) + end if + end subroutine psb_s_nrm2v_ec + + + ! + ! SUM + ! + + subroutine psb_ssums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_ssums + + subroutine psb_ssumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_ssumv + + subroutine psb_ssumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_ssumm + + subroutine psb_ssums_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_ssums_ec + + subroutine psb_ssumv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_ssumv_ec + + subroutine psb_ssumm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_ssumm_ec + + + ! + ! AMX: Maximum Absolute Value + ! + + subroutine psb_samxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_samxs + + subroutine psb_samxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_samxv + + subroutine psb_samxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_samxm + + + subroutine psb_samxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_samxs_ec + + subroutine psb_samxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_samxv_ec + + subroutine psb_samxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_samxm_ec + + + ! + ! AMN: Minimum Absolute Value + ! + + subroutine psb_samns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_samns + + subroutine psb_samnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_samnv + + subroutine psb_samnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + real(psb_spk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_samnm + + + subroutine psb_samns_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_samns_ec + + subroutine psb_samnv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_samnv_ec + + subroutine psb_samnm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_samnm_ec + + + ! + ! BCAST Broadcast + ! + + subroutine psb_sbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call mpi_bcast(dat,1,psb_mpi_r_spk_,root_,ictxt,info) + +#endif + end subroutine psb_sbcasts + + subroutine psb_sbcastv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info) +#endif + end subroutine psb_sbcastv + + subroutine psb_sbcastm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info) +#endif + end subroutine psb_sbcastm + + + subroutine psb_sbcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_sbcasts_ec + + subroutine psb_sbcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_sbcastv_ec + + subroutine psb_sbcastm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_sbcastm_ec + + + +end module psi_s_collective_mod diff --git a/base/modules/penv/psi_s_p2p_mod.F90 b/base/modules/penv/psi_s_p2p_mod.F90 new file mode 100644 index 000000000..91f4d7399 --- /dev/null +++ b/base/modules/penv/psi_s_p2p_mod.F90 @@ -0,0 +1,307 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psi_s_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_snd + module procedure psb_ssnds, psb_ssndv, psb_ssndm, & + & psb_ssnds_ec, psb_ssndv_ec, psb_ssndm_ec + end interface + + interface psb_rcv + module procedure psb_srcvs, psb_srcvv, psb_srcvm, & + & psb_srcvs_ec, psb_srcvv_ec, psb_srcvm_ec + end interface + +contains + + subroutine psb_ssnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_ssnds + + subroutine psb_ssndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:) + integer(psb_mpk_), intent(in) :: dst + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_ssndv + + subroutine psb_ssndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:,:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_ipk_), intent(in), optional :: m + real(psb_spk_), allocatable :: dat_(:) + integer(psb_ipk_) :: i,j,k,m_,n_ + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_ssndm + + subroutine psb_srcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_srcvs + + subroutine psb_srcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat(:) + integer(psb_mpk_), intent(in) :: src + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_srcvv + + subroutine psb_srcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat(:,:) + integer(psb_mpk_), intent(in) :: src + integer(psb_ipk_), intent(in), optional :: m + real(psb_spk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type + integer(psb_mpk_) :: i,j,k + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,psb_mpi_r_spk_,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_real_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_srcvm + + + subroutine psb_ssnds_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_ssnds_ec + + subroutine psb_ssndv_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_ssndv_ec + + subroutine psb_ssndm_ec(ictxt,dat,dst,m) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(in) :: dat(:,:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_ssndm_ec + + subroutine psb_srcvs_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_srcvs_ec + + subroutine psb_srcvv_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat(:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_srcvv_ec + + subroutine psb_srcvm_ec(ictxt,dat,src,m) + + integer(psb_epk_), intent(in) :: ictxt + real(psb_spk_), intent(out) :: dat(:,:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_srcvm_ec + + +end module psi_s_p2p_mod diff --git a/base/modules/penv/psi_z_collective_mod.F90 b/base/modules/penv/psi_z_collective_mod.F90 new file mode 100644 index 000000000..3ed7e4f6f --- /dev/null +++ b/base/modules/penv/psi_z_collective_mod.F90 @@ -0,0 +1,744 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_z_collective_mod + use psi_penv_mod + + + interface psb_sum + module procedure psb_zsums, psb_zsumv, psb_zsumm, & + & psb_zsums_ec, psb_zsumv_ec, psb_zsumm_ec + end interface + + interface psb_amx + module procedure psb_zamxs, psb_zamxv, psb_zamxm, & + & psb_zamxs_ec, psb_zamxv_ec, psb_zamxm_ec + end interface + + interface psb_amn + module procedure psb_zamns, psb_zamnv, psb_zamnm, & + & psb_zamns_ec, psb_zamnv_ec, psb_zamnm_ec + end interface + + + interface psb_bcast + module procedure psb_zbcasts, psb_zbcastv, psb_zbcastm, & + & psb_zbcasts_ec, psb_zbcastv_ec, psb_zbcastm_ec + end interface + + +contains + + ! !!!!!!!!!!!!!!!!!!!!!! + ! + ! Reduction operations + ! + ! !!!!!!!!!!!!!!!!!!!!!! + + + + ! + ! SUM + ! + + subroutine psb_zsums(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_zsums + + subroutine psb_zsumv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zsumv + + subroutine psb_zsumm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zsumm + + subroutine psb_zsums_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_zsums_ec + + subroutine psb_zsumv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_zsumv_ec + + subroutine psb_zsumm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_sum(ictxt_,dat,root_) + else + call psb_sum(ictxt_,dat) + end if + end subroutine psb_zsumm_ec + + + ! + ! AMX: Maximum Absolute Value + ! + + subroutine psb_zamxs(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_zamxs + + subroutine psb_zamxv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zamxv + + subroutine psb_zamxm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zamxm + + + subroutine psb_zamxs_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_zamxs_ec + + subroutine psb_zamxv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_zamxv_ec + + subroutine psb_zamxm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amx(ictxt_,dat,root_) + else + call psb_amx(ictxt_,dat) + end if + end subroutine psb_zamxm_ec + + + ! + ! AMN: Minimum Absolute Value + ! + + subroutine psb_zamns(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_) :: dat_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info) + dat = dat_ + else + call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + if (iam == root_) dat = dat_ + endif +#endif + end subroutine psb_zamns + + subroutine psb_zamnv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_) & + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + else + call psb_realloc(1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zamnv + + subroutine psb_zamnm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + complex(psb_dpk_), allocatable :: dat_(:,:) + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = -1 + endif + if (root_ == -1) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + if (iinfo == psb_success_)& + & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info) + else + if (iam == root_) then + call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) + dat_ = dat + call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + else + call psb_realloc(1,1,dat_,iinfo) + call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) + end if + endif +#endif + end subroutine psb_zamnm + + + subroutine psb_zamns_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_zamns_ec + + subroutine psb_zamnv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_zamnv_ec + + subroutine psb_zamnm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_amn(ictxt_,dat,root_) + else + call psb_amn(ictxt_,dat) + end if + end subroutine psb_zamnm_ec + + + ! + ! BCAST Broadcast + ! + + subroutine psb_zbcasts(ictxt,dat,root) +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + call mpi_bcast(dat,1,psb_mpi_c_dpk_,root_,ictxt,info) + +#endif + end subroutine psb_zbcasts + + subroutine psb_zbcastv(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + + +#if !defined(SERIAL_MPI) + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info) +#endif + end subroutine psb_zbcastv + + subroutine psb_zbcastm(ictxt,dat,root) + use psb_realloc_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_mpk_), intent(in), optional :: root + integer(psb_mpk_) :: root_ + + integer(psb_mpk_) :: iam, np, info + integer(psb_ipk_) :: iinfo + +#if !defined(SERIAL_MPI) + + call psb_info(ictxt,iam,np) + + if (present(root)) then + root_ = root + else + root_ = psb_root_ + endif + + call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info) +#endif + end subroutine psb_zbcastm + + + subroutine psb_zbcasts_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_zbcasts_ec + + subroutine psb_zbcastv_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_zbcastv_ec + + subroutine psb_zbcastm_ec(ictxt,dat,root) + implicit none + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(inout) :: dat(:,:) + integer(psb_epk_), intent(in), optional :: root + integer(psb_mpk_) :: ictxt_, root_ + + ictxt_ = ictxt + if (present(root)) then + root_ = root + call psb_bcast(ictxt_,dat,root_) + else + call psb_bcast(ictxt_,dat) + end if + end subroutine psb_zbcastm_ec + + + +end module psi_z_collective_mod diff --git a/base/modules/penv/psi_z_p2p_mod.F90 b/base/modules/penv/psi_z_p2p_mod.F90 new file mode 100644 index 000000000..b72b0ae6a --- /dev/null +++ b/base/modules/penv/psi_z_p2p_mod.F90 @@ -0,0 +1,307 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psi_z_p2p_mod + use psi_penv_mod + use psi_comm_buffers_mod + + interface psb_snd + module procedure psb_zsnds, psb_zsndv, psb_zsndm, & + & psb_zsnds_ec, psb_zsndv_ec, psb_zsndm_ec + end interface + + interface psb_rcv + module procedure psb_zrcvs, psb_zrcvv, psb_zrcvm, & + & psb_zrcvs_ec, psb_zrcvv_ec, psb_zrcvm_ec + end interface + +contains + + subroutine psb_zsnds(ictxt,dat,dst) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat + integer(psb_mpk_), intent(in) :: dst + complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info +#if defined(SERIAL_MPI) + ! do nothing +#else + allocate(dat_(1), stat=info) + dat_(1) = dat + call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_zsnds + + subroutine psb_zsndv(ictxt,dat,dst) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:) + integer(psb_mpk_), intent(in) :: dst + complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + allocate(dat_(size(dat)), stat=info) + dat_(:) = dat(:) + call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) +#endif + + end subroutine psb_zsndv + + subroutine psb_zsndm(ictxt,dat,dst,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:,:) + integer(psb_mpk_), intent(in) :: dst + integer(psb_ipk_), intent(in), optional :: m + complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_ipk_) :: i,j,k,m_,n_ + integer(psb_mpk_) :: info + +#if defined(SERIAL_MPI) +#else + if (present(m)) then + m_ = m + else + m_ = size(dat,1) + end if + n_ = size(dat,2) + allocate(dat_(m_*n_), stat=info) + k=1 + do j=1,n_ + do i=1, m_ + dat_(k) = dat(i,j) + k = k + 1 + end do + end do + call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) +#endif + end subroutine psb_zsndm + + subroutine psb_zrcvs(ictxt,dat,src) + use psi_comm_buffers_mod +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat + integer(psb_mpk_), intent(in) :: src + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! do nothing +#else + call mpi_recv(dat,1,psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_zrcvs + + subroutine psb_zrcvv(ictxt,dat,src) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat(:) + integer(psb_mpk_), intent(in) :: src + complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) +#else + call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info) + call psb_test_nodes(psb_mesg_queue) +#endif + + end subroutine psb_zrcvv + + subroutine psb_zrcvm(ictxt,dat,src,m) + use psi_comm_buffers_mod + +#ifdef MPI_MOD + use mpi +#endif + implicit none +#ifdef MPI_H + include 'mpif.h' +#endif + integer(psb_mpk_), intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat(:,:) + integer(psb_mpk_), intent(in) :: src + integer(psb_ipk_), intent(in), optional :: m + complex(psb_dpk_), allocatable :: dat_(:) + integer(psb_mpk_) :: info ,m_,n_, ld, mp_rcv_type + integer(psb_mpk_) :: i,j,k + integer(psb_mpk_) :: status(mpi_status_size) +#if defined(SERIAL_MPI) + ! What should we do here?? +#else + if (present(m)) then + m_ = m + ld = size(dat,1) + n_ = size(dat,2) + call mpi_type_vector(n_,m_,ld,psb_mpi_c_dpk_,mp_rcv_type,info) + if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) + if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& + & psb_dcomplex_tag,ictxt,status,info) + if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) + else + call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info) + end if + if (info /= mpi_success) then + write(psb_err_unit,*) 'Error in psb_recv', info + end if + call psb_test_nodes(psb_mesg_queue) +#endif + end subroutine psb_zrcvm + + + subroutine psb_zsnds_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_zsnds_ec + + subroutine psb_zsndv_ec(ictxt,dat,dst) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_zsndv_ec + + subroutine psb_zsndm_ec(ictxt,dat,dst,m) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(in) :: dat(:,:) + integer(psb_epk_), intent(in) :: dst + + integer(psb_mpk_) :: iictxt, idst + + iictxt = ictxt + idst = dst + call psb_snd(iictxt, dat, idst) + + end subroutine psb_zsndm_ec + + subroutine psb_zrcvs_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_zrcvs_ec + + subroutine psb_zrcvv_ec(ictxt,dat,src) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat(:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_zrcvv_ec + + subroutine psb_zrcvm_ec(ictxt,dat,src,m) + + integer(psb_epk_), intent(in) :: ictxt + complex(psb_dpk_), intent(out) :: dat(:,:) + integer(psb_epk_), intent(in) :: src + + integer(psb_mpk_) :: iictxt, isrc + + iictxt = ictxt + isrc = src + call psb_rcv(iictxt, dat, isrc) + + end subroutine psb_zrcvm_ec + + +end module psi_z_p2p_mod diff --git a/base/modules/psb_cbind_const_mod.F90 b/base/modules/psb_cbind_const_mod.F90 new file mode 100644 index 000000000..0f1443528 --- /dev/null +++ b/base/modules/psb_cbind_const_mod.F90 @@ -0,0 +1,52 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + +module psb_cbind_const_mod + use iso_c_binding + + integer, parameter :: psb_c_mpk = c_int32_t +#if defined(IPK4) && defined(LPK4) + integer, parameter :: psb_c_ipk = c_int32_t + integer, parameter :: psb_c_lpk = c_int32_t +#elif defined(IPK4) && defined(LPK8) + integer, parameter :: psb_c_ipk = c_int32_t + integer, parameter :: psb_c_lpk = c_int64_t +#elif defined(IPK8) && defined(LPK8) + integer, parameter :: psb_c_ipk = c_int64_t + integer, parameter :: psb_c_lpk = c_int64_t +#else + integer, parameter :: psb_c_ipk = -1 + integer, parameter :: psb_c_lpk = -1 +#endif + integer, parameter :: psb_c_epk = c_int64_t + +end module psb_cbind_const_mod diff --git a/base/modules/psb_check_mod.f90 b/base/modules/psb_check_mod.f90 index db7e6fe68..37631d5ff 100644 --- a/base/modules/psb_check_mod.f90 +++ b/base/modules/psb_check_mod.f90 @@ -72,7 +72,8 @@ contains use psb_error_mod implicit none - integer(psb_ipk_), intent(in) :: m,n,ix,jx,lldx + integer(psb_lpk_), intent(in) :: m,n,ix,jx + integer(psb_ipk_), intent(in) :: lldx type(psb_desc_type), intent(in) :: desc_dec integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional :: iix, jjx @@ -193,7 +194,8 @@ contains use psb_error_mod implicit none - integer(psb_ipk_), intent(in) :: m,n,ix,jx,lldx + integer(psb_lpk_), intent(in) :: m,n,ix,jx + integer(psb_ipk_), intent(in) :: lldx type(psb_desc_type), intent(in) :: desc_dec integer(psb_ipk_), intent(out) :: info @@ -311,7 +313,7 @@ contains use psb_error_mod implicit none - integer(psb_ipk_), intent(in) :: m,n,ia,ja + integer(psb_lpk_), intent(in) :: m,n,ia,ja type(psb_desc_type), intent(in) :: desc_dec integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional :: iia, jja diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index 5083efc00..8c01d68f8 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -33,61 +33,93 @@ module psb_const_mod #if defined(HAVE_ISO_FORTRAN_ENV) use iso_fortran_env - ! This is the default PSBLAS integer, can be 4 or 8 bytes. -#if defined(LONG_INTEGERS) - integer, parameter :: psb_ipk_ = int64 -#else - integer, parameter :: psb_ipk_ = int32 -#endif - ! This is always an 8-byte integer. - integer, parameter :: psb_long_int_k_ = int64 - integer, parameter :: psb_lpk_ = psb_long_int_k_ + ! This is a 2-byte integer, just in case + integer, parameter :: psb_i2pk_ = int16 ! This is always a 4-byte integer, for MPI-related stuff - integer, parameter :: psb_mpik_ = int32 + integer, parameter :: psb_mpk_ = int32 + ! This is always an 8-byte integer. + integer, parameter :: psb_epk_ = int64 ! ! These must be the kind parameter corresponding to psb_mpi_r_dpk_ ! and psb_mpi_r_spk_ ! - integer(psb_mpik_), parameter :: psb_spk_ = real32 - integer(psb_mpik_), parameter :: psb_dpk_ = real64 + integer, parameter :: psb_spk_ = real32 + integer, parameter :: psb_dpk_ = real64 + #else - ! This is the default PSBLAS integer, can be 4 or 8 bytes. -#if defined(LONG_INTEGERS) - integer, parameter :: ndig=12 -#else - integer, parameter :: ndig=8 -#endif - integer, parameter :: psb_ipk_ = selected_int_kind(ndig) - ! This is always an 8-byte integer. - integer, parameter :: longndig=12 - integer, parameter :: psb_long_int_k_ = selected_int_kind(longndig) - integer, parameter :: psb_lpk_ = psb_long_int_k_ + + ! This is a 2-byte integer, just in case + integer, parameter :: i2ndig=4 + integer, parameter :: psb_i2pk_ = selected_int_kind(i2ndig) ! This is always a 4-byte integer, for MPI-related stuff - integer, parameter :: psb_mpik_ = kind(1) + integer, parameter :: indig=8 + integer, parameter :: psb_mpk_ = selected_int_kind(indig) + ! This is always an 8-byte integer. + integer, parameter :: lndig=12 + integer, parameter :: psb_epk_ = selected_int_kind(lndig) ! ! These must be the kind parameter corresponding to psb_mpi_r_dpk_ ! and psb_mpi_r_spk_ ! - integer(psb_mpik_), parameter :: psb_spk_p_ = 6 - integer(psb_mpik_), parameter :: psb_spk_r_ = 37 - integer(psb_mpik_), parameter :: psb_spk_ = selected_real_kind(psb_spk_p_,psb_spk_r_) - integer(psb_mpik_), parameter :: psb_dpk_p_ = 15 - integer(psb_mpik_), parameter :: psb_dpk_r_ = 307 - integer(psb_mpik_), parameter :: psb_dpk_ = selected_real_kind(psb_dpk_p_,psb_dpk_r_) + integer, parameter :: psb_spk_p_ = 6 + integer, parameter :: psb_spk_r_ = 37 + integer, parameter :: psb_spk_ = selected_real_kind(psb_spk_p_,psb_spk_r_) + integer, parameter :: psb_dpk_p_ = 15 + integer, parameter :: psb_dpk_r_ = 307 + integer, parameter :: psb_dpk_ = selected_real_kind(psb_dpk_p_,psb_dpk_r_) #endif - integer(psb_ipk_), save :: psb_sizeof_dp, psb_sizeof_sp - integer(psb_ipk_), save :: psb_sizeof_int, psb_sizeof_long_int + ! Now for the choices: + ! IPK = integer kind for "local" indices and sizes. + ! Can be 4 or 8 bytes. + ! LPK = integer kind for "global" indices and sizes. + ! Can be 4 or 8 bytes. + ! Size must be >= size of IPK + ! + ! Additional rules: + ! 1. MPI related stuff is always MPK + ! 2. ICTXT,IAM,NP: should we have two versions of everything, + ! one with MPK the other with EPK? + ! 3. INFO, ERR_ACT, IERR etc are always IPK + ! 4. For the array version of things, where it makes sense + ! e.g. realloc, snd/receive, define as MPK,EPK and the + ! compiler will later pick up the correct version according + ! to what IPK/LPK are mapped onto. + ! +#if defined(IPK4) && defined(LPK4) + integer, parameter :: psb_ipk_ = psb_mpk_ + integer, parameter :: psb_lpk_ = psb_mpk_ +#elif defined(IPK4) && defined(LPK8) + integer, parameter :: psb_ipk_ = psb_mpk_ + integer, parameter :: psb_lpk_ = psb_epk_ +#elif defined(IPK8) && defined(LPK8) + integer, parameter :: psb_ipk_ = psb_epk_ + integer, parameter :: psb_lpk_ = psb_epk_ +#else + ! Unsupported combination, compilation will stop later on + integer, parameter :: psb_ipk_ = -1 + integer, parameter :: psb_lpk_ = -1 +#endif + + integer(psb_ipk_), save :: psb_sizeof_sp + integer(psb_ipk_), save :: psb_sizeof_dp + integer(psb_ipk_), save :: psb_sizeof_i2p + integer(psb_ipk_), save :: psb_sizeof_mp + integer(psb_ipk_), save :: psb_sizeof_ep + integer(psb_ipk_), save :: psb_sizeof_ip + integer(psb_ipk_), save :: psb_sizeof_lp ! ! Integer type identifiers for MPI operations. ! - integer(psb_mpik_), save :: psb_mpi_ipk_integer - integer(psb_mpik_), save :: psb_mpi_def_integer - integer(psb_mpik_), save :: psb_mpi_lng_integer - integer(psb_mpik_), save :: psb_mpi_r_spk_ - integer(psb_mpik_), save :: psb_mpi_r_dpk_ - integer(psb_mpik_), save :: psb_mpi_c_spk_ - integer(psb_mpik_), save :: psb_mpi_c_dpk_ + integer(psb_mpk_), save :: psb_mpi_i2pk_ + integer(psb_mpk_), save :: psb_mpi_epk_ + integer(psb_mpk_), save :: psb_mpi_mpk_ + integer(psb_mpk_), save :: psb_mpi_ipk_ + integer(psb_mpk_), save :: psb_mpi_lpk_ + integer(psb_mpk_), save :: psb_mpi_r_spk_ + integer(psb_mpk_), save :: psb_mpi_r_dpk_ + integer(psb_mpk_), save :: psb_mpi_c_spk_ + integer(psb_mpk_), save :: psb_mpi_c_dpk_ ! ! Version ! @@ -99,8 +131,15 @@ module psb_const_mod ! ! Handy & miscellaneous constants ! + integer(psb_epk_), parameter :: ezero=0, eone=1 + integer(psb_epk_), parameter :: etwo=2, ethree=3,emone=-1 + integer(psb_mpk_), parameter :: mzero=0, mone=1 + integer(psb_mpk_), parameter :: mtwo=2, mthree=3,mmone=-1 + integer(psb_lpk_), parameter :: lzero=0, lone=1 + integer(psb_lpk_), parameter :: ltwo=2, lthree=3,lmone=-1 integer(psb_ipk_), parameter :: izero=0, ione=1 - integer(psb_ipk_), parameter :: itwo=2, ithree=3,mone=-1 + integer(psb_ipk_), parameter :: itwo=2, ithree=3,imone=-1 + integer(psb_ipk_), parameter :: psb_root_=0 real(psb_spk_), parameter :: szero=0.0_psb_spk_, sone=1.0_psb_spk_ real(psb_dpk_), parameter :: dzero=0.0_psb_dpk_, done=1.0_psb_dpk_ @@ -111,11 +150,18 @@ module psb_const_mod real(psb_dpk_), parameter :: d_epstol=1.1e-16_psb_dpk_ ! Unit roundoff. real(psb_spk_), parameter :: s_epstol=5.e-8_psb_spk_ ! Is this right? character, parameter :: psb_all_='A', psb_topdef_=' ' - logical, parameter :: psb_i_is_complex_ = .false. - logical, parameter :: psb_s_is_complex_ = .false. - logical, parameter :: psb_d_is_complex_ = .false. - logical, parameter :: psb_c_is_complex_ = .true. - logical, parameter :: psb_z_is_complex_ = .true. + logical, parameter :: psb_m_is_complex_ = .false. + logical, parameter :: psb_e_is_complex_ = .false. + logical, parameter :: psb_i_is_complex_ = .false. + logical, parameter :: psb_l_is_complex_ = .false. + logical, parameter :: psb_s_is_complex_ = .false. + logical, parameter :: psb_d_is_complex_ = .false. + logical, parameter :: psb_c_is_complex_ = .true. + logical, parameter :: psb_z_is_complex_ = .true. + logical, parameter :: psb_ls_is_complex_ = .false. + logical, parameter :: psb_ld_is_complex_ = .false. + logical, parameter :: psb_lc_is_complex_ = .true. + logical, parameter :: psb_lz_is_complex_ = .true. ! ! Sort routines constants @@ -208,6 +254,8 @@ module psb_const_mod integer(psb_ipk_), parameter, public :: psb_err_forgot_spall_=295 integer(psb_ipk_), parameter, public :: psb_err_wrong_ins_=298 integer(psb_ipk_), parameter, public :: psb_err_iarg_mbeeiarra_i_=300 + integer(psb_ipk_), parameter, public :: psb_err_bad_int_cnv_=301 + integer(psb_ipk_), parameter, public :: psb_err_mpi_int_ovflw_=302 integer(psb_ipk_), parameter, public :: psb_err_mpi_error_=400 integer(psb_ipk_), parameter, public :: psb_err_parm_differs_among_procs_=550 integer(psb_ipk_), parameter, public :: psb_err_entry_out_of_bounds_=551 diff --git a/base/modules/psb_error_impl.F90 b/base/modules/psb_error_impl.F90 index a6db77963..1073f24d3 100644 --- a/base/modules/psb_error_impl.F90 +++ b/base/modules/psb_error_impl.F90 @@ -1,13 +1,26 @@ ! checks wether an error has occurred on one of the porecesses in the execution pool -subroutine psb_errcomm(ictxt, err) +subroutine psb_errcomm_i(ictxt, err) use psb_error_mod, psb_protect_name => psb_errcomm use psb_penv_mod - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(inout):: err + + if (psb_get_global_checks()) call psb_amx(ictxt, err) + +end subroutine psb_errcomm_i + +#if defined(IPK8) + +subroutine psb_errcomm_m(ictxt, err) + use psb_error_mod, psb_protect_name => psb_errcomm + use psb_penv_mod + integer(psb_mpk_), intent(in) :: ictxt integer(psb_ipk_), intent(inout):: err if (psb_get_global_checks()) call psb_amx(ictxt, err) -end subroutine psb_errcomm +end subroutine psb_errcomm_m +#endif subroutine psb_ser_error_handler(err_act) use psb_error_mod, psb_protect_name => psb_ser_error_handler @@ -30,13 +43,13 @@ subroutine psb_par_error_handler(ictxt,err_act) implicit none integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: err_act - integer(psb_mpik_) :: iictxt + call psb_erractionrestore(err_act) - iictxt = ictxt + if (err_act == psb_act_print_) & - & call psb_error(iictxt, abrt=.false.) + & call psb_error(ictxt, abrt=.false.) if (err_act == psb_act_abort_) & - & call psb_error(iictxt, abrt=.true.) + & call psb_error(ictxt, abrt=.true.) return @@ -45,7 +58,7 @@ end subroutine psb_par_error_handler subroutine psb_par_error_print_stack(ictxt) use psb_error_mod, psb_protect_name => psb_par_error_print_stack use psb_penv_mod - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: ictxt call psb_error(ictxt, abrt=.false.) @@ -68,24 +81,24 @@ subroutine psb_serror() integer(psb_ipk_) :: err_c character(len=20) :: r_name character(len=40) :: a_e_d - integer(psb_ipk_) :: i_e_d(5) + integer(psb_epk_) :: e_e_d(5) if (psb_errstatus_fatal()) then if(psb_get_errverbosity() > 1) then do while (psb_get_numerr() > izero) write(psb_err_unit,'(50("="))') - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) + call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d) ! write(psb_err_unit,'(50("="))') end do else - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) + call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d) do while (psb_get_numerr() > 0) - call psb_errpop(err_c, r_name, i_e_d, a_e_d) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) end do end if end if @@ -103,47 +116,48 @@ subroutine psb_perror(ictxt,abrt) use psb_error_mod use psb_penv_mod implicit none - integer(psb_mpik_), intent(in) :: ictxt + integer(psb_ipk_), intent(in) :: ictxt logical, intent(in), optional :: abrt integer(psb_ipk_) :: err_c character(len=20) :: r_name character(len=40) :: a_e_d - integer(psb_ipk_) :: i_e_d(5) - integer(psb_mpik_) :: iam, np + integer(psb_epk_) :: e_e_d(5) + integer(psb_mpk_) :: iictxt, iam, np logical :: abrt_ abrt_=.true. if (present(abrt)) abrt_=abrt - call psb_info(ictxt,iam,np) + iictxt = ictxt + call psb_info(iictxt,iam,np) if (psb_errstatus_fatal()) then if (psb_get_errverbosity() > 1) then do while (psb_get_numerr() > izero) write(psb_err_unit,'(50("="))') - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d,iam) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) + call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d,iam) ! write(psb_err_unit,'(50("="))') end do #if defined(HAVE_FLUSH_STMT) flush(psb_err_unit) #endif - if (abrt_) call psb_abort(ictxt,-1) + if (abrt_) call psb_abort(iictxt,-1) else - call psb_errpop(err_c, r_name, i_e_d, a_e_d) - call psb_errmsg(psb_err_unit,err_c, r_name, i_e_d, a_e_d,iam) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) + call psb_errmsg(psb_err_unit,err_c, r_name, e_e_d, a_e_d,iam) do while (psb_get_numerr() > 0) - call psb_errpop(err_c, r_name, i_e_d, a_e_d) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) end do #if defined(HAVE_FLUSH_STMT) flush(psb_err_unit) #endif - if (abrt_) call psb_abort(ictxt,-1) + if (abrt_) call psb_abort(iictxt,-1) end if end if diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index c49ed41e6..a2e37e847 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -72,7 +72,7 @@ module psb_error_mod integer(psb_ipk_), intent(inout) :: err_act end subroutine psb_ser_error_handler subroutine psb_par_error_handler(ictxt,err_act) - import :: psb_ipk_,psb_mpik_ + import :: psb_ipk_,psb_mpk_ integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(in) :: err_act end subroutine psb_par_error_handler @@ -82,8 +82,8 @@ module psb_error_mod subroutine psb_serror() end subroutine psb_serror subroutine psb_perror(ictxt,abrt) - import :: psb_mpik_ - integer(psb_mpik_), intent(in) :: ictxt + import :: psb_ipk_ + integer(psb_ipk_), intent(in) :: ictxt logical, intent(in), optional :: abrt end subroutine psb_perror end interface @@ -91,19 +91,26 @@ module psb_error_mod interface psb_error_print_stack subroutine psb_par_error_print_stack(ictxt) - import :: psb_ipk_,psb_mpik_ - integer(psb_mpik_), intent(in) :: ictxt + import :: psb_ipk_ + integer(psb_ipk_), intent(in) :: ictxt end subroutine psb_par_error_print_stack subroutine psb_ser_error_print_stack() end subroutine psb_ser_error_print_stack end interface interface psb_errcomm - subroutine psb_errcomm(ictxt, err) - import :: psb_mpik_, psb_ipk_ - integer(psb_mpik_), intent(in) :: ictxt +#if defined(IPK8) + subroutine psb_errcomm_m(ictxt, err) + import :: psb_ipk_, psb_mpk_ + integer(psb_mpk_), intent(in) :: ictxt integer(psb_ipk_), intent(inout):: err - end subroutine psb_errcomm + end subroutine psb_errcomm_m +#endif + subroutine psb_errcomm_i(ictxt, err) + import :: psb_ipk_ + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_ipk_), intent(inout):: err + end subroutine psb_errcomm_i end interface psb_errcomm interface psb_errpop @@ -114,15 +121,6 @@ module psb_error_mod module procedure psb_errmsg, psb_ach_errmsg end interface -#if defined(LONG_INTEGERS) - interface psb_error - module procedure psb_perror_ipk - end interface psb_error - interface psb_errcomm - module procedure psb_errcomm_ipk - end interface psb_errcomm -#endif - private @@ -133,7 +131,7 @@ module psb_error_mod ! the name of the routine generating the error character(len=20) :: routine='' ! array of integer data to complete the error msg - integer(psb_ipk_),dimension(5) :: i_err_data=0 + integer(psb_epk_),dimension(5) :: e_err_data=0 ! real(psb_dpk_)(dim=10) :: r_err_data=0.d0 ! array of real data to complete the error msg ! complex(dim=10) :: c_err_data=0.c0 @@ -186,22 +184,6 @@ contains end function psb_get_global_checks -#if defined(LONG_INTEGERS) - subroutine psb_errcomm_ipk(ictxt, err) - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout):: err - integer(psb_mpik_) :: iictxt - iictxt = ictxt - call psb_errcomm(iictxt,err) - end subroutine psb_errcomm_ipk - - subroutine psb_perror_ipk(ictxt) - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_mpik_) :: iictxt - iictxt = ictxt - call psb_perror(iictxt) - end subroutine psb_perror_ipk -#endif ! saves action to support error traceback ! also changes error action to "return" subroutine psb_erractionsave(err_act) @@ -352,22 +334,37 @@ contains end function psb_errstatus_ok ! pushes an error on the error stack - subroutine psb_stackpush(err_c, r_name, i_err, a_err) - + subroutine psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) integer(psb_ipk_), intent(in) :: err_c character(len=*), intent(in) :: r_name character(len=*), optional :: a_err - integer(psb_ipk_), optional :: i_err(5) + integer(psb_ipk_), optional :: i_err(:) + integer(psb_lpk_), optional :: l_err(:) + integer(psb_mpk_), optional :: m_err(:) + integer(psb_epk_), optional :: e_err(:) type(psb_errstack_node), pointer :: new_node - - + integer :: isz + allocate(new_node) new_node%err_code = err_c new_node%routine = r_name - if(present(i_err)) then - new_node%i_err_data = i_err + if (present(m_err)) then + isz = min(size(new_node%e_err_data),size(m_err)) + new_node%e_err_data(1:isz) = m_err(1:isz) + end if + if (present(e_err)) then + isz = min(size(new_node%e_err_data),size(e_err)) + new_node%e_err_data(1:isz) = e_err(1:isz) + end if + if (present(i_err)) then + isz = min(size(new_node%e_err_data),size(i_err)) + new_node%e_err_data(1:isz) = i_err(1:isz) + end if + if (present(l_err)) then + isz = min(size(new_node%e_err_data),size(l_err)) + new_node%e_err_data(1:isz) = l_err(1:isz) end if if(present(a_err)) then new_node%a_err_data = a_err @@ -380,34 +377,40 @@ contains end subroutine psb_stackpush ! pushes an error on the error stack - subroutine psb_errpush(err_c, r_name, i_err, a_err) + subroutine psb_errpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) integer(psb_ipk_), intent(in) :: err_c character(len=*), intent(in) :: r_name character(len=*), optional :: a_err - integer(psb_ipk_), optional :: i_err(5) + integer(psb_ipk_), optional :: i_err(:) + integer(psb_lpk_), optional :: l_err(:) + integer(psb_mpk_), optional :: m_err(:) + integer(psb_epk_), optional :: e_err(:) type(psb_errstack_node), pointer :: new_node call psb_set_errstatus(psb_err_fatal_) - call psb_stackpush(err_c, r_name, i_err, a_err) + call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) end subroutine psb_errpush ! pushes a warning on the error stack - subroutine psb_warning_push(err_c, r_name, i_err, a_err) + subroutine psb_warning_push(err_c, r_name, a_err, i_err, l_err, m_err, e_err) - integer(psb_ipk_), intent(in) :: err_c + integer(psb_ipk_), intent(in) :: err_c character(len=*), intent(in) :: r_name character(len=*), optional :: a_err - integer(psb_ipk_), optional :: i_err(5) + integer(psb_ipk_), optional :: i_err(:) + integer(psb_lpk_), optional :: l_err(:) + integer(psb_mpk_), optional :: m_err(:) + integer(psb_epk_), optional :: e_err(:) type(psb_errstack_node), pointer :: new_node if (.not.psb_errstatus_fatal())& & call psb_set_errstatus( psb_err_warning_) - call psb_stackpush(err_c, r_name, i_err, a_err) + call psb_stackpush(err_c, r_name, a_err, i_err, l_err, m_err, e_err) end subroutine psb_warning_push @@ -417,16 +420,16 @@ contains integer(psb_ipk_) :: err_c character(len=20) :: r_name character(len=40) :: a_e_d - integer(psb_ipk_) :: i_e_d(5) + integer(psb_epk_) :: e_e_d(5) type(psb_errstack_node), pointer :: old_node if (error_stack%n_elems > 0) then err_c = error_stack%top%err_code r_name = error_stack%top%routine - i_e_d = error_stack%top%i_err_data + e_e_d = error_stack%top%e_err_data a_e_d = error_stack%top%a_err_data - call psb_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d) + call psb_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d) old_node => error_stack%top error_stack%top => old_node%next error_stack%n_elems = error_stack%n_elems - 1 @@ -438,19 +441,19 @@ contains end subroutine psb_ach_errpop ! pops an error from the error stack - subroutine psb_errpop(err_c, r_name, i_e_d, a_e_d) + subroutine psb_errpop(err_c, r_name, e_e_d, a_e_d) integer(psb_ipk_), intent(out) :: err_c character(len=20), intent(out) :: r_name character(len=40), intent(out) :: a_e_d - integer(psb_ipk_), intent(out) :: i_e_d(5) + integer(psb_epk_), intent(out) :: e_e_d(5) type(psb_errstack_node), pointer :: old_node if (error_stack%n_elems > 0) then err_c = error_stack%top%err_code r_name = error_stack%top%routine - i_e_d = error_stack%top%i_err_data + e_e_d = error_stack%top%e_err_data a_e_d = error_stack%top%a_err_data old_node => error_stack%top @@ -469,24 +472,24 @@ contains integer(psb_ipk_) :: err_c character(len=20) :: r_name character(len=40) :: a_e_d - integer(psb_ipk_) :: i_e_d(5) + integer(psb_epk_) :: e_e_d(5) do while (psb_get_numerr() > 0) - call psb_errpop(err_c, r_name, i_e_d, a_e_d) + call psb_errpop(err_c, r_name, e_e_d, a_e_d) end do end subroutine psb_clean_errstack ! prints the error msg associated to a specific error code - subroutine psb_ach_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d,me) + subroutine psb_ach_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d,me) character(len=psb_max_errmsg_len_), allocatable, intent(out) :: achmsg(:) - integer(psb_ipk_), intent(in) :: err_c - character(len=20), intent(in) :: r_name - character(len=40), intent(in) :: a_e_d - integer(psb_ipk_), intent(in) :: i_e_d(5) - integer(psb_mpik_), optional :: me + integer(psb_ipk_), intent(in) :: err_c + character(len=20), intent(in) :: r_name + character(len=40), intent(in) :: a_e_d + integer(psb_epk_), intent(in) :: e_e_d(5) + integer(psb_mpk_), optional :: me character(len=psb_max_errmsg_len_) :: tmpmsg @@ -511,12 +514,12 @@ contains case(psb_err_pivot_too_small_) allocate(achmsg(2)) achmsg(1) = tmpmsg - write(achmsg(2),'("pivot too small: ",i0,1x,a)')i_e_d(1),trim(a_e_d) + write(achmsg(2),'("pivot too small: ",i0,1x,a)')e_e_d(1),trim(a_e_d) case(psb_err_invalid_ovr_num_) allocate(achmsg(2)) achmsg(1) = tmpmsg - write(achmsg(2),'("Invalid number of ovr:",i0)')i_e_d(1) + write(achmsg(2),'("Invalid number of ovr:",i0)')e_e_d(1) case(psb_err_invalid_input_) allocate(achmsg(2)) @@ -526,37 +529,37 @@ contains case(psb_err_iarg_neg_) allocate(achmsg(3)) achmsg(1) = tmpmsg - write(achmsg(2),'("input argument n. ",i0," cannot be less than 0")')i_e_d(1) - write(achmsg(3),'("current value is ",i0)')i_e_d(2) + write(achmsg(2),'("input argument n. ",i0," cannot be less than 0")')e_e_d(1) + write(achmsg(3),'("current value is ",i0)')e_e_d(2) case(psb_err_iarg_pos_) allocate(achmsg(3)) achmsg(1) = tmpmsg - write(achmsg(2),'("input argument n. ",i0," cannot be greater than 0")')i_e_d(1) - write(achmsg(3),'("current value is ",i0)')i_e_d(2) + write(achmsg(2),'("input argument n. ",i0," cannot be greater than 0")')e_e_d(1) + write(achmsg(3),'("current value is ",i0)')e_e_d(2) case(psb_err_input_value_invalid_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg - write(achmsg(2),'("input argument n. ",i0," has an invalid value")')i_e_d(1) - write(achmsg(3),'("current value is ",i0)')i_e_d(2) + write(achmsg(2),'("input argument n. ",i0," has an invalid value")')e_e_d(1) + write(achmsg(3),'("current value is ",i0)')e_e_d(2) case(psb_err_input_asize_invalid_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg - write(achmsg(2),'("Size of input array argument n. ",i0," is invalid.")')i_e_d(1) - write(achmsg(3),'("Current value is ",i0)')i_e_d(2) + write(achmsg(2),'("Size of input array argument n. ",i0," is invalid.")')e_e_d(1) + write(achmsg(3),'("Current value is ",i0)')e_e_d(2) case(psb_err_input_asize_small_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg - write(achmsg(2),'("Size of input array argument n. ",i0," is too small.")')i_e_d(1) - write(achmsg(3),'("Current value is ",i0," Should be at least ",i0)') i_e_d(2),i_e_d(3) + write(achmsg(2),'("Size of input array argument n. ",i0," is too small.")')e_e_d(1) + write(achmsg(3),'("Current value is ",i0," Should be at least ",i0)') e_e_d(2),e_e_d(3) case(psb_err_iarg_invalid_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg - write(achmsg(2),'("input argument n. ",i0," has an invalid value")')i_e_d(1) + write(achmsg(2),'("input argument n. ",i0," has an invalid value")')e_e_d(1) write(achmsg(3),'("current value is ",a)')a_e_d(2:2) case(psb_err_iarg_not_gtia_ii_) @@ -564,37 +567,37 @@ contains achmsg(1) = tmpmsg write(achmsg(2),& & '("input argument n. ",i0," must be equal or greater than input argument n. ",i0)') & - & i_e_d(1), i_e_d(3) + & e_e_d(1), e_e_d(3) write(achmsg(3),'("current values are ",i0," < ",i0)')& - & i_e_d(2),i_e_d(5) + & e_e_d(2),e_e_d(5) case(psb_err_iarg_not_gteia_ii_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," must be greater than or equal to ",i0)')& - & i_e_d(1),i_e_d(2) + & e_e_d(1),e_e_d(2) write(achmsg(3),'("current value is ",i0," < ",i0)')& - & i_e_d(3), i_e_d(2) + & e_e_d(3), e_e_d(2) case(psb_err_iarg_invalid_value_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," in entry # ",i0," has an invalid value")')& - & i_e_d(1:2) + & e_e_d(1:2) write(achmsg(3),'("current value is ",a)')trim(a_e_d) case(psb_err_asb_nrc_error_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("Impossible error in ASB: nrow>ncol,")') - write(achmsg(3),'("Actual values are ",i0," > ",i0)')i_e_d(1:2) + write(achmsg(3),'("Actual values are ",i0," > ",i0)')e_e_d(1:2) ! ... csr format error ... case(psb_err_iarg2_neg_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument ia2(1) is less than 0")') - write(achmsg(3),'("current value is ",i0)')i_e_d(1) + write(achmsg(3),'("current value is ",i0)')e_e_d(1) ! ... csr format error ... case(psb_err_ia2_not_increasing_) @@ -612,7 +615,7 @@ contains allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("indices in ia1 array are not within problem dimension")') - write(achmsg(3),'("problem dimension is ",i0)')i_e_d(1) + write(achmsg(3),'("problem dimension is ",i0)')e_e_d(1) case(psb_err_invalid_args_combination_) allocate(achmsg(2)) @@ -623,15 +626,15 @@ contains allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("Invalid process identifier in input array argument n. ",i0,".")')& - & i_e_d(1) - write(achmsg(3),'("Current value is ",i0)')i_e_d(2) + & e_e_d(1) + write(achmsg(3),'("Current value is ",i0)')e_e_d(2) case(psb_err_iarg_n_mbgtian_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," must be greater than input argument n. ",i0)')& - & i_e_d(1:2) - write(achmsg(3),'("current values are ",i0," < ",i0)') i_e_d(3:4) + & e_e_d(1:2) + write(achmsg(3),'("current values are ",i0," < ",i0)') e_e_d(3:4) case(psb_err_dupl_cd_vl) allocate(achmsg(2)) @@ -669,14 +672,14 @@ contains achmsg(1) = tmpmsg write(achmsg(2),& &'("indices in input array are not within problem dimension ",2(i0,2x))')& - &i_e_d(1:2) + &e_e_d(1:2) case(psb_err_iarray_outside_process_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("indices in input array are not belonging to the calling process ",i0)')& - & i_e_d(1) + & e_e_d(1) case(psb_err_forgot_geall_) allocate(achmsg(2)) @@ -697,31 +700,44 @@ contains &'("Something went wrong before this call to ",a,", probably in cdins/spins")')& & trim(r_name) + case(psb_err_bad_int_cnv_) + allocate(achmsg(2)) + achmsg(1) = tmpmsg + write(achmsg(2),& + & '("Bad integer conversion from ",i0,"to ",i0)') & + & e_e_d(1),e_e_d(2) + + case(psb_err_mpi_int_ovflw_) + allocate(achmsg(2)) + achmsg(1) = tmpmsg + write(achmsg(2),& + & '("Size argument to MPI overflow.")') + case(psb_err_iarg_mbeeiarra_i_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Input argument n. ",i0," must be equal to entry n. ",i0," in array input argument n.",i0)') & - & i_e_d(1),i_e_d(4),i_e_d(3) - write(achmsg(3),'("Current values are ",i0," != ",i0)')i_e_d(2), i_e_d(5) + & e_e_d(1),e_e_d(4),e_e_d(3) + write(achmsg(3),'("Current values are ",i0," != ",i0)')e_e_d(2), e_e_d(5) case(psb_err_mpi_error_) allocate(achmsg(2)) achmsg(1) = tmpmsg - write(achmsg(2),'("MPI error:",i0)')i_e_d(1) + write(achmsg(2),'("MPI error:",i0)')e_e_d(1) case(psb_err_parm_differs_among_procs_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& - &'("Parameter n. ",i0," must be equal on all processes. ",i0)')i_e_d(1) + &'("Parameter n. ",i0," must be equal on all processes. ",i0)')e_e_d(1) case(psb_err_entry_out_of_bounds_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& &'("Entry n. ",i0," out of ",i0," should be between 1 and ",i0," but is ",i0)')& - & i_e_d(1),i_e_d(3),i_e_d(4),i_e_d(2) + & e_e_d(1),e_e_d(3),e_e_d(4),e_e_d(2) case(psb_err_inconsistent_index_lists_) allocate(achmsg(2)) @@ -733,31 +749,31 @@ contains achmsg(1) = tmpmsg write(achmsg(2),& &'("partition function passed as input argument n. ",i0," returns number of processes")')& - &i_e_d(1) + &e_e_d(1) write(achmsg(3),& & '("greater than No of grid s processes on global point ",i0,". Actual number of grid s ")')& - &i_e_d(4) - write(achmsg(4),'("processes is ",i0,", number returned is ",i0)')i_e_d(2),i_e_d(3) + &e_e_d(4) + write(achmsg(4),'("processes is ",i0,", number returned is ",i0)')e_e_d(2),e_e_d(3) case(psb_err_partfunc_toofewprocs_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& &'("partition function passed as input argument n. ",i0," returns number of processes")')& - &i_e_d(1) + &e_e_d(1) write(achmsg(3),& &'("less or equal to 0 on global point ",i0,". Number returned is ",i0)')& - &i_e_d(3),i_e_d(2) + &e_e_d(3),e_e_d(2) case(psb_err_partfunc_wrong_pid_) allocate(achmsg(3)) achmsg(1) = tmpmsg write(achmsg(2),& &'("partition function passed as input argument n. ",i0," returns wrong processes identifier")')& - & i_e_d(1) + & e_e_d(1) write(achmsg(3),& & '("on global point ",i0,". Current value returned is : ",i0)')& - & i_e_d(3),i_e_d(2) + & e_e_d(3),e_e_d(2) case(psb_err_no_optional_arg_) allocate(achmsg(2)) @@ -789,11 +805,11 @@ contains allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("input argument n. ",i0," has a dynamic type not allowed here.")')& - & i_e_d(1) + & e_e_d(1) case(psb_err_rectangular_mat_unsupported_) write(achmsg(2),& &'("This routine does not support rectangular matrices: ",i0, " /= ",i0)') & - & i_e_d(1), i_e_d(2) + & e_e_d(1), e_e_d(2) case(psb_err_invalid_mat_state_) allocate(achmsg(2)) @@ -927,7 +943,7 @@ contains achmsg(1) = tmpmsg write(achmsg(2),& & '("Decompostion type ",i0," not yet supported.")')& - & i_e_d(1) + & e_e_d(1) case(3090) allocate(achmsg(2)) @@ -941,7 +957,7 @@ contains & '("Error on index. Element has not been inserted")') write(achmsg(3),& & '("local index is: ",i0," and global index is:",i0)')& - & i_e_d(1:2) + & e_e_d(1:2) case(psb_err_input_matrix_unassembled_) allocate(achmsg(2)) @@ -1000,37 +1016,37 @@ contains allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Error ",i0," from call to a subroutine ")')& - & i_e_d(1) + & e_e_d(1) case(psb_err_from_subroutine_ai_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),'("Error from call to subroutine ",a," ",i0)')& - & trim(a_e_d),i_e_d(1) + & trim(a_e_d),e_e_d(1) case(psb_err_alloc_request_) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Error on allocation request for ",i0," items of type ",a)')& - & i_e_d(1),trim(a_e_d) + & e_e_d(1),trim(a_e_d) case(4110) allocate(achmsg(2)) achmsg(1) = tmpmsg write(achmsg(2),& & '("Error ",i0," from call to an external package in subroutine ",a)')& - &i_e_d(1),trim(a_e_d) + &e_e_d(1),trim(a_e_d) case(psb_err_invalid_istop_) allocate(achmsg(2)) achmsg(1) = tmpmsg - write(achmsg(2),'("Invalid ISTOP: ",i0)')i_e_d(1) + write(achmsg(2),'("Invalid ISTOP: ",i0)')e_e_d(1) case(5002) allocate(achmsg(2)) achmsg(1) = tmpmsg - write(achmsg(2),'("Invalid PREC: ",i0)')i_e_d(1) + write(achmsg(2),'("Invalid PREC: ",i0)')e_e_d(1) case(5003) allocate(achmsg(2)) @@ -1042,7 +1058,7 @@ contains achmsg(1) = tmpmsg write(achmsg(2),'("unknown error (",i0,") in subroutine ",a)')& & err_c,trim(r_name) - write(achmsg(3),'(5(i0,2x))') i_e_d + write(achmsg(3),'(5(i0,2x))') e_e_d write(achmsg(4),'(a)') trim(a_e_d) end select @@ -1051,18 +1067,18 @@ contains ! prints the error msg associated to a specific error code - subroutine psb_errmsg(iunit, err_c, r_name, i_e_d, a_e_d,me) + subroutine psb_errmsg(iunit, err_c, r_name, e_e_d, a_e_d,me) integer(psb_ipk_), intent(in) :: iunit integer(psb_ipk_), intent(in) :: err_c character(len=20), intent(in) :: r_name character(len=40), intent(in) :: a_e_d - integer(psb_ipk_), intent(in) :: i_e_d(5) - integer(psb_mpik_), optional :: me + integer(psb_epk_), intent(in) :: e_e_d(5) + integer(psb_mpk_), optional :: me integer(psb_ipk_) :: i character(len=psb_max_errmsg_len_), allocatable :: achmsg(:) - call psb_ach_errmsg(achmsg,err_c, r_name, i_e_d, a_e_d,me) + call psb_ach_errmsg(achmsg,err_c, r_name, e_e_d, a_e_d,me) do i=1,size(achmsg) write(iunit,'(a)') trim(achmsg(i)) diff --git a/base/modules/psb_penv_mod.F90 b/base/modules/psb_penv_mod.F90 index 17f0f6a77..14c3f2386 100644 --- a/base/modules/psb_penv_mod.F90 +++ b/base/modules/psb_penv_mod.F90 @@ -3,9 +3,8 @@ module psb_penv_mod use psi_penv_mod - use psi_bcast_mod - use psi_reduce_mod use psi_p2p_mod - + use psi_collective_mod + end module psb_penv_mod diff --git a/base/modules/psb_realloc_mod.F90 b/base/modules/psb_realloc_mod.F90 index 9d15c6ae9..fba5fd0d7 100644 --- a/base/modules/psb_realloc_mod.F90 +++ b/base/modules/psb_realloc_mod.F90 @@ -31,128 +31,19 @@ ! module psb_realloc_mod use psb_const_mod + use psb_m_realloc_mod + use psb_e_realloc_mod + use psb_s_realloc_mod + use psb_d_realloc_mod + use psb_c_realloc_mod + use psb_z_realloc_mod + implicit none ! - ! psb_realloc will reallocate the input array to have exactly - ! the size specified, possibly shortening it. + ! Does it make sense to do maloc/frees in inner loops? + ! In normal CPU environments yes, on GPUS no. ! - Interface psb_realloc - module procedure psb_reallocate1i - module procedure psb_reallocate2i - module procedure psb_reallocate2i1d - module procedure psb_reallocate2i1s - module procedure psb_reallocate1d - module procedure psb_reallocate1s - module procedure psb_reallocated2 - module procedure psb_reallocates2 - module procedure psb_reallocatei2 -#if ! defined(LONG_INTEGERS) - module procedure psb_reallocate1i8 - module procedure psb_reallocatei8_2 -#endif - module procedure psb_reallocate2i1z - module procedure psb_reallocate2i1c - module procedure psb_reallocate1z - module procedure psb_reallocate1c - module procedure psb_reallocatez2 - module procedure psb_reallocatec2 -#if defined(LONG_INTEGERS) - module procedure psb_reallocate1i4 - module procedure psb_reallocate1i4_i8 - module procedure psb_reallocate2i4 - module procedure psb_reallocate2i4_i8 - module procedure psb_rp1i1 - module procedure psb_rp1i2i2 - module procedure psb_ri1p2i2 - module procedure psb_rp1p2i2 - - module procedure psb_rp1s1 - module procedure psb_rp1i2s2 - module procedure psb_ri1p2s2 - module procedure psb_rp1p2s2 - - module procedure psb_rp1d1 - module procedure psb_rp1i2d2 - module procedure psb_ri1p2d2 - module procedure psb_rp1p2d2 - - module procedure psb_rp1c1 - module procedure psb_rp1i2c2 - module procedure psb_ri1p2c2 - module procedure psb_rp1p2c2 - - module procedure psb_rp1z1 - module procedure psb_rp1i2z2 - module procedure psb_ri1p2z2 - module procedure psb_rp1p2z2 - -#endif - end Interface psb_realloc - - interface psb_move_alloc - module procedure psb_smove_alloc1d - module procedure psb_smove_alloc2d - module procedure psb_dmove_alloc1d - module procedure psb_dmove_alloc2d - module procedure psb_imove_alloc1d - module procedure psb_imove_alloc2d -#if !defined(LONG_INTEGERS) - module procedure psb_i8move_alloc1d - module procedure psb_i8move_alloc2d -#else - module procedure psb_i4move_alloc1d - module procedure psb_i4move_alloc2d - module procedure psb_i4move_alloc1d_i8 - module procedure psb_i4move_alloc2d_i8 -#endif - module procedure psb_cmove_alloc1d - module procedure psb_cmove_alloc2d - module procedure psb_zmove_alloc1d - module procedure psb_zmove_alloc2d - end interface psb_move_alloc - - Interface psb_safe_ab_cpy - module procedure psb_i_ab_cpy1d,psb_i_ab_cpy2d, & - & psb_s_ab_cpy1d, psb_s_ab_cpy2d,& - & psb_c_ab_cpy1d, psb_c_ab_cpy2d,& - & psb_d_ab_cpy1d, psb_d_ab_cpy2d,& - & psb_z_ab_cpy1d, psb_z_ab_cpy2d - end Interface psb_safe_ab_cpy - - Interface psb_safe_cpy - module procedure psb_i_cpy1d,psb_i_cpy2d, & - & psb_s_cpy1d, psb_s_cpy2d,& - & psb_c_cpy1d, psb_c_cpy2d,& - & psb_d_cpy1d, psb_d_cpy2d,& - & psb_z_cpy1d, psb_z_cpy2d - end Interface psb_safe_cpy - - ! - ! psb_ensure_size will reallocate the input array if necessary - ! to guarantee that its size is at least as large as the - ! value required, usually with some room to spare. - ! - interface psb_ensure_size - module procedure psb_icksz1d,& -#if !defined(LONG_INTEGERS) - & psb_i8cksz1d, & -#endif - & psb_scksz1d, psb_ccksz1d, & - & psb_dcksz1d, psb_zcksz1d - end Interface psb_ensure_size - - interface psb_size - module procedure psb_isize1d, psb_isize2d,& -#if !defined(LONG_INTEGERS) - & psb_i8size1d, psb_i8size2d,& -#endif - & psb_ssize1d, psb_ssize2d,& - & psb_csize1d, psb_csize2d,& - & psb_dsize1d, psb_dsize2d,& - & psb_zsize1d, psb_zsize2d - end interface psb_size - logical, private :: do_maybe_free_buffer = .true. Contains @@ -167,3465 +58,5 @@ Contains do_maybe_free_buffer = val end subroutine psb_set_maybe_free_buffer - subroutine psb_i_ab_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),allocatable, intent(in) :: vin(:) - integer(psb_ipk_),allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - - if (psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_i_ab_cpy1d - - subroutine psb_i_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_i_ab_cpy2d - - subroutine psb_s_ab_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_spk_), allocatable, intent(in) :: vin(:) - real(psb_spk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_s_ab_cpy1d - - subroutine psb_s_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_spk_), allocatable, intent(in) :: vin(:,:) - real(psb_spk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_s_ab_cpy2d - - subroutine psb_d_ab_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_dpk_), allocatable, intent(in) :: vin(:) - real(psb_dpk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_d_ab_cpy1d - - subroutine psb_d_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_dpk_), allocatable, intent(in) :: vin(:,:) - real(psb_dpk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_d_ab_cpy2d - - subroutine psb_c_ab_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_spk_), allocatable, intent(in) :: vin(:) - complex(psb_spk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_c_ab_cpy1d - - subroutine psb_c_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_spk_), allocatable, intent(in) :: vin(:,:) - complex(psb_spk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_c_ab_cpy2d - - subroutine psb_z_ab_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_dpk_), allocatable, intent(in) :: vin(:) - complex(psb_dpk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - if (allocated(vin)) then - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_z_ab_cpy1d - - subroutine psb_z_ab_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) - complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_ab_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - if (allocated(vin)) then - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_z_ab_cpy2d - - - subroutine psb_i_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_), intent(in) :: vin(:) - integer(psb_ipk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_i_cpy1d - - subroutine psb_i_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_), intent(in) :: vin(:,:) - integer(psb_ipk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_i_cpy2d - - subroutine psb_s_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_spk_), intent(in) :: vin(:) - real(psb_spk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_s_cpy1d - - subroutine psb_s_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_spk_), intent(in) :: vin(:,:) - real(psb_spk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_s_cpy2d - - subroutine psb_d_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_dpk_), intent(in) :: vin(:) - real(psb_dpk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_d_cpy1d - - subroutine psb_d_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - real(psb_dpk_), intent(in) :: vin(:,:) - real(psb_dpk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_d_cpy2d - - subroutine psb_c_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_spk_), intent(in) :: vin(:) - complex(psb_spk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_c_cpy1d - - subroutine psb_c_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_spk_), intent(in) :: vin(:,:) - complex(psb_spk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_c_cpy2d - - subroutine psb_z_cpy1d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_dpk_), intent(in) :: vin(:) - complex(psb_dpk_), allocatable, intent(out) :: vout(:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz,err_act,lb - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - isz = size(vin) - lb = lbound(vin,1) - call psb_realloc(isz,vout,info,lb=lb) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:) = vin(:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_z_cpy1d - - subroutine psb_z_cpy2d(vin,vout,info) - use psb_error_mod - - ! ...Subroutine Arguments - complex(psb_dpk_), intent(in) :: vin(:,:) - complex(psb_dpk_), allocatable, intent(out) :: vout(:,:) - integer(psb_ipk_) :: info - ! ...Local Variables - - integer(psb_ipk_) :: isz1, isz2,err_act, lb1, lb2 - character(len=20) :: name, char_err - logical, parameter :: debug=.false. - - name='psb_safe_cpy' - call psb_erractionsave(err_act) - - info=psb_success_ - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - isz1 = size(vin,1) - isz2 = size(vin,2) - lb1 = lbound(vin,1) - lb2 = lbound(vin,2) - call psb_realloc(isz1,isz2,vout,info,lb1=lb1,lb2=lb2) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - char_err='psb_realloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - else - vout(:,:) = vin(:,:) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - end subroutine psb_z_cpy2d - - - function psb_isize1d(vin) - integer(psb_ipk_) :: psb_isize1d - integer(psb_ipk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_isize1d = 0 - else - psb_isize1d = size(vin) - end if - end function psb_isize1d - - function psb_isize2d(vin,dim) - integer(psb_ipk_) :: psb_isize2d - integer(psb_ipk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - if (.not.allocated(vin)) then - psb_isize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_isize2d = size(vin,dim=dim_) - else - psb_isize2d = size(vin) - end if - end if - end function psb_isize2d - -#if !defined(LONG_INTEGERS) - function psb_i8size1d(vin) - integer(psb_ipk_) :: psb_i8size1d - integer(psb_long_int_k_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_i8size1d = 0 - else - psb_i8size1d = size(vin) - end if - end function psb_i8size1d - - function psb_i8size2d(vin,dim) - integer(psb_ipk_) :: psb_i8size2d - integer(psb_long_int_k_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - if (.not.allocated(vin)) then - psb_i8size2d = 0 - else - if (present(dim)) then - dim_= dim - psb_i8size2d = size(vin,dim=dim_) - else - psb_i8size2d = size(vin) - end if - end if - end function psb_i8size2d -#endif - - function psb_ssize1d(vin) - integer(psb_ipk_) :: psb_ssize1d - real(psb_spk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_ssize1d = 0 - else - psb_ssize1d = size(vin) - end if - end function psb_ssize1d - - function psb_ssize2d(vin,dim) - integer(psb_ipk_) :: psb_ssize2d - real(psb_spk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - - if (.not.allocated(vin)) then - psb_ssize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_ssize2d = size(vin,dim=dim_) - else - psb_ssize2d = size(vin) - end if - end if - end function psb_ssize2d - - function psb_dsize1d(vin) - integer(psb_ipk_) :: psb_dsize1d - real(psb_dpk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_dsize1d = 0 - else - psb_dsize1d = size(vin) - end if - end function psb_dsize1d - - function psb_dsize2d(vin,dim) - integer(psb_ipk_) :: psb_dsize2d - real(psb_dpk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - - if (.not.allocated(vin)) then - psb_dsize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_dsize2d = size(vin,dim=dim_) - else - psb_dsize2d = size(vin) - end if - end if - end function psb_dsize2d - - - function psb_csize1d(vin) - integer(psb_ipk_) :: psb_csize1d - complex(psb_spk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_csize1d = 0 - else - psb_csize1d = size(vin) - end if - end function psb_csize1d - - function psb_csize2d(vin,dim) - integer(psb_ipk_) :: psb_csize2d - complex(psb_spk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - if (.not.allocated(vin)) then - psb_csize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_csize2d = size(vin,dim=dim_) - else - psb_csize2d = size(vin) - end if - end if - end function psb_csize2d - - function psb_zsize1d(vin) - integer(psb_ipk_) :: psb_zsize1d - complex(psb_dpk_), allocatable, intent(in) :: vin(:) - - if (.not.allocated(vin)) then - psb_zsize1d = 0 - else - psb_zsize1d = size(vin) - end if - end function psb_zsize1d - - function psb_zsize2d(vin,dim) - integer(psb_ipk_) :: psb_zsize2d - complex(psb_dpk_), allocatable, intent(in) :: vin(:,:) - integer(psb_ipk_), optional :: dim - integer(psb_ipk_) :: dim_ - - if (.not.allocated(vin)) then - psb_zsize2d = 0 - else - if (present(dim)) then - dim_= dim - psb_zsize2d = size(vin,dim=dim_) - else - psb_zsize2d = size(vin) - end if - end if - end function psb_zsize2d - - - Subroutine psb_icksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - call psb_realloc(isz,v,info,pad=pad) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - end if - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_icksz1d - -#if !defined(LONG_INTEGERS) - Subroutine psb_i8cksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Integer(psb_long_int_k_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_long_int_k_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - call psb_realloc(isz,v,info,pad=pad) - - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - end if - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - End Subroutine psb_i8cksz1d -#endif - - Subroutine psb_scksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - real(psb_spk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - real(psb_spk_), optional, intent(in) :: pad - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - - call psb_realloc(isz,v,info,pad=pad) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - End If - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_scksz1d - - Subroutine psb_dcksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - real(psb_dpk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - real(psb_dpk_), optional, intent(in) :: pad - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - - call psb_realloc(isz,v,info,pad=pad) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - End If - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_dcksz1d - - - Subroutine psb_ccksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - complex(psb_spk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - complex(psb_spk_), optional, intent(in) :: pad - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - call psb_realloc(isz,v,info,pad=pad) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - end if - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_ccksz1d - - - Subroutine psb_zcksz1d(len,v,info,pad,addsz,newsz) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - complex(psb_dpk_),allocatable, intent(inout) :: v(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: addsz,newsz - complex(psb_dpk_), optional, intent(in) :: pad - ! ...Local Variables - character(len=20) :: name - logical, parameter :: debug=.false. - integer(psb_ipk_) :: isz, err_act - - name='psb_ensure_size' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - If (len > psb_size(v)) Then - if (present(newsz)) then - isz = (max(len+1,newsz)) - else - if (present(addsz)) then - isz = len+max(1,addsz) - else - isz = max(len+10, int(1.25*len)) - endif - endif - call psb_realloc(isz,v,info,pad=pad) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - end if - end If - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - - End Subroutine psb_zcksz1d - - - Subroutine psb_reallocate1i(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - ! ...Local Variables - integer(psb_ipk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim, err_act, err,lb_, lbi, ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name,& - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,info) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - - call psb_error_handler(err_act) - - return - - End Subroutine psb_reallocate1i - - Subroutine psb_reallocate1s(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Real(psb_spk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - - ! ...Local Variables - Real(psb_spk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim,err_act,err, lb_, lbi,ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1s' - call psb_erractionsave(err_act) - info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate S',len - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - ub_ = lb_ + len-1 - - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - Allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate1s - - Subroutine psb_reallocate1d(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Real(psb_dpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - - ! ...Local Variables - Real(psb_dpk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim,err_act,err, lb_, lbi,ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1d' - call psb_erractionsave(err_act) - info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate D',len - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - ub_ = lb_ + len-1 - - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - Allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate1d - - - Subroutine psb_reallocate1c(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - complex(psb_spk_),allocatable, intent(inout):: rrax(:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - - ! ...Local Variables - complex(psb_spk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim,err_act,err,lb_,ub_,lbi - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1c' - call psb_erractionsave(err_act) - info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate C',len - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - ub_ = lb_+len-1 - - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - call psb_move_alloc(tmp,rrax,info) - end if - else - dim = 0 - Allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate1c - - Subroutine psb_reallocate1z(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - complex(psb_dpk_),allocatable, intent(inout):: rrax(:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - - ! ...Local Variables - complex(psb_dpk_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim,err_act,err,lb_,ub_,lbi - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1z' - call psb_erractionsave(err_act) - info=psb_success_ - if (debug) write(psb_err_unit,*) 'reallocate Z',len - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - ub_ = lb_+len-1 - - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - call psb_move_alloc(tmp,rrax,info) - end if - else - dim = 0 - Allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate1z - - - - Subroutine psb_reallocates2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - Real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - - Real(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocates2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_spk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocates2 - - - Subroutine psb_reallocated2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - - Real(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocated2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='real(psb_dpk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocated2 - - - Subroutine psb_reallocatec2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - - complex(psb_spk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err,dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocatec2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_spk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocatec2 - - Subroutine psb_reallocatez2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - - complex(psb_dpk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err,dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocatez2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='complex(psb_dpk_)') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocatez2 - - - Subroutine psb_reallocatei2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - integer(psb_ipk_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocatei2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocatei2 - -#if !defined(LONG_INTEGERS) - - Subroutine psb_reallocate1i8(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Integer(psb_long_int_k_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_long_int_k_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - ! ...Local Variables - Integer(psb_long_int_k_),allocatable :: tmp(:) - integer(psb_ipk_) :: dim, err_act, err,lb_, lbi, ub_ - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,info) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - - End Subroutine psb_reallocate1i8 - - Subroutine psb_reallocatei8_2(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - integer(psb_long_int_k_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_long_int_k_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - integer(psb_long_int_k_),allocatable :: tmp(:,:) - integer(psb_ipk_) :: dim,err_act,err, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - character(len=20) :: name - - name='psb_reallocatei2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - if (len2 < 0) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025 - call psb_errpush(err,name, & - & i_err=(/len1*len2,izero,izero,izero,izero/),a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocatei8_2 -#endif - - Subroutine psb_reallocate2i(len,rrax,y,info,pad) - use psb_error_mod - ! ...Subroutine Arguments - - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - - name='psb_reallocate2i' - call psb_erractionsave(err_act) - info=psb_success_ - - if(psb_get_errstatus() /= 0) then - info=psb_err_from_subroutine_ - goto 9999 - end if - - call psb_reallocate1i(len,rrax,info,pad=pad) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_reallocate1i(len,y,info,pad=pad) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - - End Subroutine psb_reallocate2i - - - - - Subroutine psb_reallocate2i1s(len,rrax,y,z,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - Real(psb_spk_),allocatable, intent(inout) :: z(:) - integer(psb_ipk_) :: info - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - logical, parameter :: debug=.false. - - name='psb_reallocate2i1s' - call psb_erractionsave(err_act) - - - info=psb_success_ - call psb_realloc(len,rrax,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,y,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,z,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - End Subroutine psb_reallocate2i1s - - - Subroutine psb_reallocate2i1d(len,rrax,y,z,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - Real(psb_dpk_),allocatable, intent(inout) :: z(:) - integer(psb_ipk_) :: info - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - - name='psb_reallocate2i1d' - call psb_erractionsave(err_act) - - info=psb_success_ - - call psb_realloc(len,rrax,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,y,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,z,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - End Subroutine psb_reallocate2i1d - - - - Subroutine psb_reallocate2i1c(len,rrax,y,z,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - complex(psb_spk_),allocatable, intent(inout) :: z(:) - integer(psb_ipk_) :: info - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - - name='psb_reallocate2i1c' - call psb_erractionsave(err_act) - - - info=psb_success_ - call psb_realloc(len,rrax,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,y,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,z,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - End Subroutine psb_reallocate2i1c - - Subroutine psb_reallocate2i1z(len,rrax,y,z,info) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:),y(:) - complex(psb_dpk_),allocatable, intent(inout) :: z(:) - integer(psb_ipk_) :: info - character(len=20) :: name - integer(psb_ipk_) :: err_act, err - - name='psb_reallocate2i1z' - call psb_erractionsave(err_act) - - info=psb_success_ - call psb_realloc(len,rrax,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,y,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_realloc(len,z,info) - if (info /= psb_success_) then - err=4000 - call psb_errpush(err,name) - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - End Subroutine psb_reallocate2i1z - - Subroutine psb_smove_alloc1d(vin,vout,info) - use psb_error_mod - real(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_smove_alloc1d - - Subroutine psb_smove_alloc2d(vin,vout,info) - use psb_error_mod - real(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_smove_alloc2d - - Subroutine psb_dmove_alloc1d(vin,vout,info) - use psb_error_mod - real(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_dmove_alloc1d - - Subroutine psb_dmove_alloc2d(vin,vout,info) - use psb_error_mod - real(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_dmove_alloc2d - - Subroutine psb_cmove_alloc1d(vin,vout,info) - use psb_error_mod - complex(psb_spk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_cmove_alloc1d - - Subroutine psb_cmove_alloc2d(vin,vout,info) - use psb_error_mod - complex(psb_spk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_cmove_alloc2d - - Subroutine psb_zmove_alloc1d(vin,vout,info) - use psb_error_mod - complex(psb_dpk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_zmove_alloc1d - - Subroutine psb_zmove_alloc2d(vin,vout,info) - use psb_error_mod - complex(psb_dpk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_zmove_alloc2d - - Subroutine psb_imove_alloc1d(vin,vout,info) - use psb_error_mod - integer(psb_ipk_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_imove_alloc1d - - Subroutine psb_imove_alloc2d(vin,vout,info) - use psb_error_mod - integer(psb_ipk_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_imove_alloc2d - -#if !defined(LONG_INTEGERS) - Subroutine psb_i8move_alloc1d(vin,vout,info) - use psb_error_mod - integer(psb_long_int_k_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i8move_alloc1d - - Subroutine psb_i8move_alloc2d(vin,vout,info) - use psb_error_mod - integer(psb_long_int_k_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i8move_alloc2d - -#else - - Subroutine psb_i4move_alloc1d(vin,vout,info) - use psb_error_mod - integer(psb_mpik_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_mpik_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i4move_alloc1d - - Subroutine psb_i4move_alloc1d_i8(vin,vout,info) - use psb_error_mod - integer(psb_mpik_), allocatable, intent(inout) :: vin(:),vout(:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i4move_alloc1d_i8 - - Subroutine psb_i4move_alloc2d(vin,vout,info) - use psb_error_mod - integer(psb_mpik_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_mpik_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i4move_alloc2d - - Subroutine psb_i4move_alloc2d_i8(vin,vout,info) - use psb_error_mod - integer(psb_mpik_), allocatable, intent(inout) :: vin(:,:),vout(:,:) - integer(psb_ipk_), intent(out) :: info - ! - ! - info=psb_success_ - - call move_alloc(vin,vout) - - end Subroutine psb_i4move_alloc2d_i8 - -#endif - -#if defined(LONG_INTEGERS) - Subroutine psb_reallocate1i4(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - Integer(psb_mpik_),allocatable, intent(inout) :: rrax(:) - integer(psb_mpik_) :: info - integer(psb_mpik_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - ! ...Local Variables - Integer(psb_mpik_),allocatable :: tmp(:) - integer(psb_mpik_) :: dim, lb_, lbi, ub_ - integer(psb_ipk_) :: err, err_act, ierr(5) - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i4' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,info) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',info - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - - End Subroutine psb_reallocate1i4 - - Subroutine psb_reallocate1i4_i8(len,rrax,info,pad,lb) - use psb_error_mod - - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len - Integer(psb_mpik_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_mpik_), optional, intent(in) :: pad - integer(psb_ipk_), optional, intent(in) :: lb - ! ...Local Variables - Integer(psb_mpik_),allocatable :: tmp(:) - integer(psb_mpik_) :: dim, lb_, lbi, ub_, iinfo - integer(psb_ipk_) :: err, err_act, ierr(5) - character(len=20) :: name - logical, parameter :: debug=.false. - - name='psb_reallocate1i4' - call psb_erractionsave(err_act) - info=psb_success_ - - if (debug) write(psb_err_unit,*) 'reallocate I',len - if (psb_get_errstatus() /= 0) then - if (debug) write(psb_err_unit,*) 'reallocate errstatus /= 0' - info=psb_err_from_subroutine_ - goto 9999 - end if - - if (present(lb)) then - lb_ = lb - else - lb_ = 1 - endif - if ((len<0)) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - ub_ = lb_+len-1 - if (debug) write(psb_err_unit,*) 'reallocate : lb ub ',lb_, ub_ - if (allocated(rrax)) then - dim = size(rrax) - lbi = lbound(rrax,1) - If ((dim /= len).or.(lbi /= lb_)) Then - Allocate(tmp(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - tmp(lb_:lb_-1+min(len,dim))=rrax(lbi:lbi-1+min(len,dim)) - if (debug) write(psb_err_unit,*) 'reallocate : calling move_alloc ' - call psb_move_alloc(tmp,rrax,iinfo) - if (debug) write(psb_err_unit,*) 'reallocate : from move_alloc ',iinfo - end if - else - dim = 0 - allocate(rrax(lb_:ub_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb_-1+dim+1:lb_-1+len) = pad - endif - if (debug) write(psb_err_unit,*) 'end reallocate : ',info - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - - End Subroutine psb_reallocate1i4_i8 - - Subroutine psb_reallocate2i4(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1,len2 - integer(psb_mpik_),allocatable :: rrax(:,:) - integer(psb_mpik_) :: info - integer(psb_mpik_), optional, intent(in) :: pad - integer(psb_mpik_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - integer(psb_mpik_),allocatable :: tmp(:,:) - integer(psb_mpik_) :: dim, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - integer(psb_ipk_) :: err,err_act, ierr(5) - character(len=20) :: name - - name='psb_reallocatei2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025; ierr(1) = len1 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - if (len2 < 0) then - err=4025; ierr(1) = len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len1*len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len1*len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate2i4 - - Subroutine psb_reallocate2i4_i8(len1,len2,rrax,info,pad,lb1,lb2) - use psb_error_mod - ! ...Subroutine Arguments - integer(psb_ipk_),Intent(in) :: len1,len2 - integer(psb_mpik_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_mpik_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - ! ...Local Variables - integer(psb_mpik_),allocatable :: tmp(:,:) - integer(psb_mpik_) :: dim, dim2,lb1_, lb2_, ub1_, ub2_,& - & lbi1, lbi2 - integer(psb_ipk_) :: err,err_act, ierr(5) - character(len=20) :: name - - name='psb_reallocatei2' - call psb_erractionsave(err_act) - info=psb_success_ - if (present(lb1)) then - lb1_ = lb1 - else - lb1_ = 1 - endif - if (present(lb2)) then - lb2_ = lb2 - else - lb2_ = 1 - endif - ub1_ = lb1_ + len1 -1 - ub2_ = lb2_ + len2 -1 - - if (len1 < 0) then - err=4025; ierr(1) = len1 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - if (len2 < 0) then - err=4025; ierr(1) = len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - - if (allocated(rrax)) then - dim = size(rrax,1) - lbi1 = lbound(rrax,1) - dim2 = size(rrax,2) - lbi2 = lbound(rrax,2) - If ((dim /= len1).or.(dim2 /= len2).or.(lbi1 /= lb1_)& - & .or.(lbi2 /= lb2_)) Then - Allocate(tmp(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len1*len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - tmp(lb1_:lb1_-1+min(len1,dim),lb2_:lb2_-1+min(len2,dim2)) = & - & rrax(lbi1:lbi1-1+min(len1,dim),lbi2:lbi2-1+min(len2,dim2)) - call psb_move_alloc(tmp,rrax,info) - End If - else - dim = 0 - dim2 = 0 - Allocate(rrax(lb1_:ub1_,lb2_:ub2_),stat=info) - if (info /= psb_success_) then - err=4025; ierr(1) = len1*len2 - call psb_errpush(err,name,i_err=ierr,a_err='integer') - goto 9999 - end if - endif - if (present(pad)) then - rrax(lb1_-1+dim+1:lb1_-1+len1,:) = pad - rrax(lb1_:lb1_-1+dim,lb2_-1+dim2+1:lb2_-1+len2) = pad - endif - - call psb_erractionrestore(err_act) - return - -9999 continue - info = err - call psb_error_handler(err_act) - return - - End Subroutine psb_reallocate2i4_i8 - - - Subroutine psb_rp1i1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - integer(psb_ipk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1i1 - - - subroutine psb_rp1i2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2i2 - - subroutine psb_ri1p2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2i2 - - subroutine psb_rp1p2i2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - integer(psb_ipk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2i2 - - Subroutine psb_rp1s1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - real(psb_spk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1s1 - - subroutine psb_rp1i2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2s2 - - subroutine psb_ri1p2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2s2 - - subroutine psb_rp1p2s2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - real(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2s2 - - - - Subroutine psb_rp1d1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - Real(psb_dpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1d1 - - - subroutine psb_rp1i2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2d2 - - subroutine psb_ri1p2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2d2 - - subroutine psb_rp1p2d2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - Real(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - real(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2d2 - - - - Subroutine psb_rp1c1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - complex(psb_spk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1c1 - - subroutine psb_rp1i2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2c2 - - subroutine psb_ri1p2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2c2 - - subroutine psb_rp1p2c2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - complex(psb_spk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_spk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2c2 - - - Subroutine psb_rp1z1(len,rrax,info,pad,lb) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len - Complex(psb_dpk_),allocatable, intent(inout) :: rrax(:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_mpik_), optional, intent(in) :: lb - - integer(psb_ipk_) :: ilen, ilb - - ilen=len - if (present(lb)) then - ilb=lb - else - ilb = 1 - end if - call psb_realloc(ilen,rrax,info,lb=ilb,pad=pad) - - end Subroutine psb_rp1z1 - - subroutine psb_rp1i2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_ipk_),Intent(in) :: len2 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - call psb_realloc(len1_,len2,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1i2z2 - - subroutine psb_ri1p2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len2 - integer(psb_ipk_),Intent(in) :: len1 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len2_ = len2 - call psb_realloc(len1,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_ri1p2z2 - - subroutine psb_rp1p2z2(len1,len2,rrax,info,pad,lb1,lb2) - ! ...Subroutine Arguments - integer(psb_mpik_),Intent(in) :: len1 - integer(psb_mpik_),Intent(in) :: len2 - Complex(psb_dpk_),allocatable :: rrax(:,:) - integer(psb_ipk_) :: info - complex(psb_dpk_), optional, intent(in) :: pad - integer(psb_ipk_),Intent(in), optional :: lb1,lb2 - - integer(psb_ipk_) :: len1_, len2_ - len1_ = len1 - len2_ = len2 - call psb_realloc(len1_,len2_,rrax,info,pad,lb1,lb2) - end subroutine psb_rp1p2z2 - -#endif - - - subroutine i_trans(a,at) - implicit none - integer(psb_ipk_) :: nr,nc - integer(psb_ipk_) :: a(:,:) - integer(psb_ipk_), allocatable, intent(out) :: at(:,:) - integer(psb_ipk_) :: i,j,ib, ii - integer(psb_ipk_), parameter :: nb=32 - - nr = size(a,1) - nc = size(a,2) - allocate(at(nc,nr)) - do i=1,nr,nb - ib=min(nb,nr-i+1) - do ii=i,i+ib-1 - do j=1,nc - at(j,ii) = a(ii,j) - end do - end do - end do - end subroutine i_trans - - subroutine d_trans(a,at) - implicit none - integer(psb_ipk_) :: nr,nc - real(psb_dpk_) :: a(:,:) - real(psb_dpk_), allocatable, intent(out) :: at(:,:) - integer(psb_ipk_) :: i,j,ib, ii - integer(psb_ipk_), parameter :: nb=32 - - nr = size(a,1) - nc = size(a,2) - allocate(at(nc,nr)) - do i=1,nr,nb - ib=min(nb,nr-i+1) - do ii=i,i+ib-1 - do j=1,nc - at(j,ii) = a(ii,j) - end do - end do - end do - end subroutine d_trans end module psb_realloc_mod diff --git a/base/modules/psi_bcast_mod.F90 b/base/modules/psi_bcast_mod.F90 deleted file mode 100644 index 6aa2ac3c2..000000000 --- a/base/modules/psi_bcast_mod.F90 +++ /dev/null @@ -1,1002 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! - - -module psi_bcast_mod - use psb_const_mod - use psi_penv_mod - interface psb_bcast - module procedure psb_ibcasts, psb_ibcastv, psb_ibcastm,& - & psb_dbcasts, psb_dbcastv, psb_dbcastm,& - & psb_zbcasts, psb_zbcastv, psb_zbcastm,& - & psb_sbcasts, psb_sbcastv, psb_sbcastm,& - & psb_cbcasts, psb_cbcastv, psb_cbcastm,& - & psb_hbcasts, psb_hbcastv,& - & psb_lbcasts, psb_lbcastv - end interface psb_bcast - -#if defined(LONG_INTEGERS) - interface psb_bcast - module procedure psb_ibcasts_ic, psb_ibcastv_ic, psb_ibcastm_ic,& - & psb_dbcasts_ic, psb_dbcastv_ic, psb_dbcastm_ic,& - & psb_zbcasts_ic, psb_zbcastv_ic, psb_zbcastm_ic,& - & psb_sbcasts_ic, psb_sbcastv_ic, psb_sbcastm_ic,& - & psb_cbcasts_ic, psb_cbcastv_ic, psb_cbcastm_ic,& - & psb_hbcasts_ic, psb_hbcastv_ic, & - & psb_lbcasts_ic, psb_lbcastv_ic - end interface psb_bcast -#else - interface psb_bcast - module procedure psb_i8bcasts, psb_i8bcastv, psb_i8bcastm - end interface psb_bcast -#endif - -contains - - ! !!!!!!!!!!!!!!!!!!!!!! - ! - ! Broadcasts - ! - ! !!!!!!!!!!!!!!!!!!!!!! - - - subroutine psb_ibcasts(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,1,psb_mpi_ipk_integer,root_,ictxt,info) -#endif - end subroutine psb_ibcasts - - subroutine psb_ibcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_ipk_integer,root_,ictxt,info) -#endif - end subroutine psb_ibcastv - - subroutine psb_ibcastm(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_ipk_integer,root_,ictxt,info) -#endif - end subroutine psb_ibcastm - - - subroutine psb_sbcasts(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,1,psb_mpi_r_spk_,root_,ictxt,info) -#endif - end subroutine psb_sbcasts - - - subroutine psb_sbcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info) - -#endif - end subroutine psb_sbcastv - - subroutine psb_sbcastm(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_r_spk_,root_,ictxt,info) - -#endif - end subroutine psb_sbcastm - - - subroutine psb_dbcasts(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,1,psb_mpi_r_dpk_,root_,ictxt,info) -#endif - end subroutine psb_dbcasts - - - subroutine psb_dbcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info) -#endif - end subroutine psb_dbcastv - - subroutine psb_dbcastm(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_r_dpk_,root_,ictxt,info) -#endif - end subroutine psb_dbcastm - - subroutine psb_cbcasts(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,1,psb_mpi_c_spk_,root_,ictxt,info) -#endif - end subroutine psb_cbcasts - - subroutine psb_cbcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info) -#endif - end subroutine psb_cbcastv - - subroutine psb_cbcastm(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_c_spk_,root_,ictxt,info) -#endif - end subroutine psb_cbcastm - - subroutine psb_zbcasts(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,1,psb_mpi_c_dpk_,root_,ictxt,info) -#endif - end subroutine psb_zbcasts - - subroutine psb_zbcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info) -#endif - end subroutine psb_zbcastv - - subroutine psb_zbcastm(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_c_dpk_,root_,ictxt,info) -#endif - end subroutine psb_zbcastm - - - subroutine psb_hbcasts(ictxt,dat,root,length) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - character(len=*), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root,length - - integer(psb_mpik_) :: iam, np, root_,length_,info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - if (present(length)) then - length_ = length - else - length_ = len(dat) - endif - - call psb_info(ictxt,iam,np) - - call mpi_bcast(dat,length_,MPI_CHARACTER,root_,ictxt,info) -#endif - - end subroutine psb_hbcasts - - subroutine psb_hbcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - character(len=*), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_,length_,info, size_ - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - length_ = len(dat) - size_ = size(dat) - - call psb_info(ictxt,iam,np) - - call mpi_bcast(dat,length_*size_,MPI_CHARACTER,root_,ictxt,info) -#endif - - end subroutine psb_hbcastv - - subroutine psb_lbcasts(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - logical, intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_,info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,1,MPI_LOGICAL,root_,ictxt,info) -#endif - - end subroutine psb_lbcasts - - - subroutine psb_lbcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - logical, intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_,info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),MPI_LOGICAL,root_,ictxt,info) -#endif - - end subroutine psb_lbcastv - - -#if !defined(LONG_INTEGERS) - - subroutine psb_i8bcasts(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,1,psb_mpi_lng_integer,root_,ictxt,info) -#endif - end subroutine psb_i8bcasts - - subroutine psb_i8bcastv(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_lng_integer,root_,ictxt,info) -#endif - end subroutine psb_i8bcastv - - subroutine psb_i8bcastm(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - - integer(psb_mpik_) :: iam, np, root_, info - -#if !defined(SERIAL_MPI) - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - - call psb_info(ictxt,iam,np) - call mpi_bcast(dat,size(dat),psb_mpi_lng_integer,root_,ictxt,info) -#endif - end subroutine psb_i8bcastm - -#endif - - -#if defined(LONG_INTEGERS) - - subroutine psb_ibcasts_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_ibcasts_ic - - subroutine psb_ibcastv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_ibcastv_ic - - subroutine psb_ibcastm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_ibcastm_ic - - - subroutine psb_sbcasts_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_sbcasts_ic - - - subroutine psb_sbcastv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_sbcastv_ic - - subroutine psb_sbcastm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_sbcastm_ic - - - subroutine psb_dbcasts_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_dbcasts_ic - - - subroutine psb_dbcastv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_dbcastv_ic - - subroutine psb_dbcastm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_dbcastm_ic - - subroutine psb_cbcasts_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_cbcasts_ic - - subroutine psb_cbcastv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_cbcastv_ic - - subroutine psb_cbcastm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_cbcastm_ic - - subroutine psb_zbcasts_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_zbcasts_ic - - subroutine psb_zbcastv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_zbcastv_ic - - subroutine psb_zbcastm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_zbcastm_ic - - - subroutine psb_hbcasts_ic(ictxt,dat,root,length) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - character(len=*), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root,length - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_hbcasts_ic - - subroutine psb_hbcastv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - character(len=*), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_hbcastv_ic - - subroutine psb_lbcasts_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_lbcasts_ic - - - subroutine psb_lbcastv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - - integer(psb_mpik_) :: iictxt, root_ - - iictxt = ictxt - if (present(root)) then - root_ = root - else - root_ = psb_root_ - endif - call psb_bcast(iictxt,dat,root_) - end subroutine psb_lbcastv_ic -#endif - - -end module psi_bcast_mod diff --git a/base/modules/psi_c_mod.F90 b/base/modules/psi_c_mod.F90 new file mode 100644 index 000000000..d59d26a21 --- /dev/null +++ b/base/modules/psi_c_mod.F90 @@ -0,0 +1,41 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_c_mod + + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type + use psi_c_comm_a_mod + use psb_c_base_vect_mod, only : psb_c_base_vect_type + use psb_c_base_multivect_mod, only : psb_c_base_multivect_type + use psi_c_comm_v_mod + +end module psi_c_mod + diff --git a/base/modules/psi_d_mod.F90 b/base/modules/psi_d_mod.F90 new file mode 100644 index 000000000..f39527f12 --- /dev/null +++ b/base/modules/psi_d_mod.F90 @@ -0,0 +1,41 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_d_mod + + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type + use psi_d_comm_a_mod + use psb_d_base_vect_mod, only : psb_d_base_vect_type + use psb_d_base_multivect_mod, only : psb_d_base_multivect_type + use psi_d_comm_v_mod + +end module psi_d_mod + diff --git a/base/modules/psi_i_mod.F90 b/base/modules/psi_i_mod.F90 new file mode 100644 index 000000000..b41f20b52 --- /dev/null +++ b/base/modules/psi_i_mod.F90 @@ -0,0 +1,225 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_i_mod + + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_ + use psi_m_comm_a_mod + use psi_e_comm_a_mod + use psb_i_base_vect_mod, only : psb_i_base_vect_type + use psb_i_base_multivect_mod, only : psb_i_base_multivect_type + use psi_i_comm_v_mod + + interface psi_compute_size + subroutine psi_i_compute_size(desc_data,& + & index_in, dl_lda, info) + import + implicit none + integer(psb_ipk_) :: info + integer(psb_ipk_) :: dl_lda + integer(psb_ipk_) :: desc_data(:), index_in(:) + end subroutine psi_i_compute_size + end interface + + interface psi_crea_bnd_elem + subroutine psi_i_crea_bnd_elem(bndel,desc_a,info) + import + implicit none + integer(psb_ipk_), allocatable :: bndel(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i_crea_bnd_elem + end interface + + interface psi_crea_index + subroutine psi_i_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: nxch,nsnd,nrcv + integer(psb_ipk_), intent(in) :: index_in(:) + integer(psb_ipk_), allocatable, intent(inout) :: index_out(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i_crea_index + end interface + + interface psi_crea_ovr_elem + subroutine psi_i_crea_ovr_elem(me,desc_overlap,ovr_elem,info) + import + implicit none + integer(psb_ipk_), intent(in) :: me, desc_overlap(:) + integer(psb_ipk_), allocatable, intent(out) :: ovr_elem(:,:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i_crea_ovr_elem + end interface + + interface psi_desc_index + subroutine psi_i_desc_index(desc,index_in,dep_list,& + & length_dl,nsnd,nrcv,desc_index,info) + import + implicit none + type(psb_desc_type) :: desc + integer(psb_ipk_) :: index_in(:),dep_list(:) + integer(psb_ipk_),allocatable :: desc_index(:) + integer(psb_ipk_) :: length_dl,nsnd,nrcv + integer(psb_ipk_) :: info + end subroutine psi_i_desc_index + end interface + + interface psi_dl_check + subroutine psi_i_dl_check(dep_list,dl_lda,np,length_dl) + import + implicit none + integer(psb_ipk_) :: np,dl_lda,length_dl(0:np) + integer(psb_ipk_) :: dep_list(dl_lda,0:np) + end subroutine psi_i_dl_check + end interface + + interface psi_sort_dl + subroutine psi_i_sort_dl(dep_list,l_dep_list,np,info) + import + implicit none + integer(psb_ipk_) :: dep_list(:,:), l_dep_list(:) + integer(psb_ipk_) :: np + integer(psb_ipk_) :: info + end subroutine psi_i_sort_dl + end interface + + interface psi_extract_dep_list + subroutine psi_i_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& + & length_dl,np,dl_lda,mode,info) + import + implicit none + logical :: is_bld, is_upd + integer(psb_ipk_) :: ictxt + integer(psb_ipk_) :: dl_lda,mode + integer(psb_ipk_) :: desc_str(*),dep_list(dl_lda,0:np),length_dl(0:np) + integer(psb_ipk_) :: np + integer(psb_ipk_) :: info + end subroutine psi_i_extract_dep_list + end interface + + interface psi_fnd_owner + subroutine psi_i_fnd_owner(nv,idx,iprc,desc,info) + import + implicit none + integer(psb_ipk_), intent(in) :: nv + integer(psb_ipk_), intent(in) :: idx(:) + integer(psb_ipk_), allocatable, intent(out) :: iprc(:) + type(psb_desc_type), intent(in) :: desc + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i_fnd_owner + end interface psi_fnd_owner + + interface psi_bld_tmphalo + subroutine psi_bld_tmphalo(desc,info) + import + implicit none + type(psb_desc_type), intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + end subroutine psi_bld_tmphalo + end interface psi_bld_tmphalo + + + interface psi_bld_tmpovrl + subroutine psi_i_bld_tmpovrl(iv,desc,info) + import + implicit none + integer(psb_ipk_), intent(in) :: iv(:) + type(psb_desc_type), intent(inout) :: desc + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i_bld_tmpovrl + end interface psi_bld_tmpovrl + + interface psi_cnv_dsc + subroutine psi_i_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) + import + implicit none + integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) + type(psb_desc_type), intent(inout) :: cdesc + integer(psb_ipk_), intent(out) :: info + class(psb_i_base_vect_type), optional, intent(in) :: mold + end subroutine psi_i_cnv_dsc + end interface psi_cnv_dsc + + interface psi_renum_index + subroutine psi_i_renum_index(iperm,idx,info) + import + implicit none + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in) :: iperm(:) + integer(psb_ipk_), intent(inout) :: idx(:) + end subroutine psi_i_renum_index + end interface psi_renum_index + + interface psi_inner_cnv + subroutine psi_i_inner_cnvs(x,hashmask,hashv,glb_lc) + import + implicit none + integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer(psb_ipk_), intent(inout) :: x + end subroutine psi_i_inner_cnvs + subroutine psi_i_inner_cnvs2(x,y,hashmask,hashv,glb_lc) + import + implicit none + integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) + integer(psb_ipk_), intent(in) :: x + integer(psb_ipk_), intent(out) :: y + end subroutine psi_i_inner_cnvs2 + subroutine psi_i_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) + import + implicit none + integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in), optional :: mask(:) + integer(psb_ipk_), intent(inout) :: x(:) + end subroutine psi_i_inner_cnv1 + subroutine psi_i_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) + import + implicit none + integer(psb_ipk_), intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) + logical, intent(in),optional :: mask(:) + integer(psb_ipk_), intent(in) :: x(:) + integer(psb_ipk_), intent(out) :: y(:) + end subroutine psi_i_inner_cnv2 + end interface psi_inner_cnv + + interface psi_bld_ovr_mst + subroutine psi_i_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) + import + implicit none + integer(psb_ipk_), intent(in) :: me, ovrlap_elem(:,:) + integer(psb_ipk_), allocatable, intent(out) :: mst_idx(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psi_i_bld_ovr_mst + end interface + +end module psi_i_mod + diff --git a/base/modules/psi_i_mod.f90 b/base/modules/psi_i_mod.f90 deleted file mode 100644 index c6e65f26c..000000000 --- a/base/modules/psi_i_mod.f90 +++ /dev/null @@ -1,453 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -module psi_i_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpik_ - use psb_i_base_vect_mod, only : psb_i_base_vect_type - use psb_i_base_multivect_mod, only : psb_i_base_multivect_type - - interface - subroutine psi_compute_size(desc_data,& - & index_in, dl_lda, info) - import - integer(psb_ipk_) :: info, dl_lda - integer(psb_ipk_) :: desc_data(:), index_in(:) - end subroutine psi_compute_size - end interface - - interface - subroutine psi_crea_bnd_elem(bndel,desc_a,info) - import - integer(psb_ipk_), allocatable :: bndel(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_crea_bnd_elem - end interface - - interface - subroutine psi_crea_index(desc_a,index_in,index_out,nxch,nsnd,nrcv,info) - import - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info,nxch,nsnd,nrcv - integer(psb_ipk_), intent(in) :: index_in(:) - integer(psb_ipk_), allocatable, intent(inout) :: index_out(:) - end subroutine psi_crea_index - end interface - - interface - subroutine psi_crea_ovr_elem(me,desc_overlap,ovr_elem,info) - import - integer(psb_ipk_), intent(in) :: me, desc_overlap(:) - integer(psb_ipk_), allocatable, intent(out) :: ovr_elem(:,:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_crea_ovr_elem - end interface - - interface - subroutine psi_desc_index(desc,index_in,dep_list,& - & length_dl,nsnd,nrcv,desc_index,info) - import - type(psb_desc_type) :: desc - integer(psb_ipk_) :: index_in(:),dep_list(:) - integer(psb_ipk_),allocatable :: desc_index(:) - integer(psb_ipk_) :: length_dl,nsnd,nrcv,info - end subroutine psi_desc_index - end interface - - interface - subroutine psi_dl_check(dep_list,dl_lda,np,length_dl) - import - integer(psb_ipk_) :: np,dl_lda,length_dl(0:np) - integer(psb_ipk_) :: dep_list(dl_lda,0:np) - end subroutine psi_dl_check - end interface - - interface - subroutine psi_sort_dl(dep_list,l_dep_list,np,info) - import - integer(psb_ipk_) :: np,dep_list(:,:), l_dep_list(:), info - end subroutine psi_sort_dl - end interface - - interface - subroutine psi_extract_dep_list(ictxt,is_bld,is_upd,desc_str,dep_list,& - & length_dl,np,dl_lda,mode,info) - import - logical :: is_bld, is_upd - integer(psb_ipk_) :: ictxt - integer(psb_ipk_) :: np,dl_lda,mode, info - integer(psb_ipk_) :: desc_str(*),dep_list(dl_lda,0:np),length_dl(0:np) - end subroutine psi_extract_dep_list - end interface - - interface psi_fnd_owner - subroutine psi_fnd_owner(nv,idx,iprc,desc,info) - import - integer(psb_ipk_), intent(in) :: nv - integer(psb_ipk_), intent(in) :: idx(:) - integer(psb_ipk_), allocatable, intent(out) :: iprc(:) - type(psb_desc_type), intent(in) :: desc - integer(psb_ipk_), intent(out) :: info - end subroutine psi_fnd_owner - end interface psi_fnd_owner - - interface psi_bld_tmphalo - subroutine psi_bld_tmphalo(desc,info) - import - type(psb_desc_type), intent(inout) :: desc - integer(psb_ipk_), intent(out) :: info - end subroutine psi_bld_tmphalo - end interface psi_bld_tmphalo - - - interface psi_bld_tmpovrl - subroutine psi_bld_tmpovrl(iv,desc,info) - import - integer(psb_ipk_), intent(in) :: iv(:) - type(psb_desc_type), intent(inout) :: desc - integer(psb_ipk_), intent(out) :: info - end subroutine psi_bld_tmpovrl - end interface psi_bld_tmpovrl - - interface psi_cnv_dsc - subroutine psi_cnv_dsc(halo_in,ovrlap_in,ext_in,cdesc, info, mold) - import - integer(psb_ipk_), intent(in) :: halo_in(:), ovrlap_in(:),ext_in(:) - type(psb_desc_type), intent(inout) :: cdesc - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type), optional, intent(in) :: mold - end subroutine psi_cnv_dsc - end interface psi_cnv_dsc - - interface psi_renum_index - subroutine psi_renum_index(iperm,idx,info) - import - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in) :: iperm(:) - integer(psb_ipk_), intent(inout) :: idx(:) - end subroutine psi_renum_index - end interface psi_renum_index - - interface psi_inner_cnv - subroutine psi_inner_cnvs(x,hashmask,hashv,glb_lc) - import - integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) - integer(psb_ipk_), intent(inout) :: x - end subroutine psi_inner_cnvs - subroutine psi_inner_cnvs2(x,y,hashmask,hashv,glb_lc) - import - integer(psb_ipk_), intent(in) :: hashmask,hashv(0:),glb_lc(:,:) - integer(psb_ipk_), intent(in) :: x - integer(psb_ipk_), intent(out) :: y - end subroutine psi_inner_cnvs2 - subroutine psi_inner_cnv1(n,x,hashmask,hashv,glb_lc,mask) - import - integer(psb_ipk_), intent(in) :: n,hashmask,hashv(0:),glb_lc(:,:) - logical, intent(in), optional :: mask(:) - integer(psb_ipk_), intent(inout) :: x(:) - end subroutine psi_inner_cnv1 - subroutine psi_inner_cnv2(n,x,y,hashmask,hashv,glb_lc,mask) - import - integer(psb_ipk_), intent(in) :: n, hashmask,hashv(0:),glb_lc(:,:) - logical, intent(in),optional :: mask(:) - integer(psb_ipk_), intent(in) :: x(:) - integer(psb_ipk_), intent(out) :: y(:) - end subroutine psi_inner_cnv2 - end interface psi_inner_cnv - - interface - subroutine psi_bld_ovr_mst(me,ovrlap_elem,mst_idx,info) - import - integer(psb_ipk_), intent(in) :: me, ovrlap_elem(:,:) - integer(psb_ipk_), allocatable, intent(out) :: mst_idx(:) - integer(psb_ipk_), intent(out) :: info - end subroutine psi_bld_ovr_mst - end interface - - - interface psi_swapdata - subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:,:), beta - integer(psb_ipk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_iswapdatam - subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:), beta - integer(psb_ipk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_iswapdatav - subroutine psi_iswapdata_vect(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_iswapdata_vect - subroutine psi_iswapdata_multivect(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_iswapdata_multivect - subroutine psi_iswapidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:,:), beta - integer(psb_ipk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_iswapidxm - subroutine psi_iswapidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:), beta - integer(psb_ipk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_iswapidxv - subroutine psi_iswap_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - end subroutine psi_iswap_vidx_vect - subroutine psi_iswap_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - end subroutine psi_iswap_vidx_multivect - end interface psi_swapdata - - - interface psi_swaptran - subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag, n - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:,:), beta - integer(psb_ipk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_iswaptranm - subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:), beta - integer(psb_ipk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_iswaptranv - subroutine psi_iswaptran_vect(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_iswaptran_vect - subroutine psi_iswaptran_multivect(flag,beta,y,desc_a,work,info,data) - import - integer(psb_ipk_), intent(in) :: flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_),target :: work(:) - type(psb_desc_type), target :: desc_a - integer(psb_ipk_), optional :: data - end subroutine psi_iswaptran_multivect - subroutine psi_itranidxm(ictxt,icomm,flag,n,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag, n - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:,:), beta - integer(psb_ipk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_itranidxm - subroutine psi_itranidxv(ictxt,icomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: ictxt,icomm,flag - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: y(:), beta - integer(psb_ipk_),target :: work(:) - integer(psb_ipk_), intent(in) :: idx(:),totxch,totsnd,totrcv - end subroutine psi_itranidxv - subroutine psi_itran_vidx_vect(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_vect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - end subroutine psi_itran_vidx_vect - subroutine psi_itran_vidx_multivect(iictxt,iicomm,flag,beta,y,idx,& - & totxch,totsnd,totrcv,work,info) - import - integer(psb_ipk_), intent(in) :: iictxt,iicomm,flag - integer(psb_ipk_), intent(out) :: info - class(psb_i_base_multivect_type) :: y - integer(psb_ipk_) :: beta - integer(psb_ipk_), target :: work(:) - class(psb_i_base_vect_type), intent(inout) :: idx - integer(psb_ipk_), intent(in) :: totxch,totsnd, totrcv - end subroutine psi_itran_vidx_multivect - end interface psi_swaptran - - interface psi_ovrl_upd - subroutine psi_iovrl_updr1(x,desc_a,update,info) - import - integer(psb_ipk_), intent(inout), target :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_updr1 - subroutine psi_iovrl_updr2(x,desc_a,update,info) - import - integer(psb_ipk_), intent(inout), target :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_updr2 - subroutine psi_iovrl_upd_vect(x,desc_a,update,info) - import - class(psb_i_base_vect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_upd_vect - subroutine psi_iovrl_upd_multivect(x,desc_a,update,info) - import - class(psb_i_base_multivect_type) :: x - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: update - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_upd_multivect - end interface psi_ovrl_upd - - interface psi_ovrl_save - subroutine psi_iovrl_saver1(x,xs,desc_a,info) - import - integer(psb_ipk_), intent(inout) :: x(:) - integer(psb_ipk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_saver1 - subroutine psi_iovrl_saver2(x,xs,desc_a,info) - import - integer(psb_ipk_), intent(inout) :: x(:,:) - integer(psb_ipk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_saver2 - subroutine psi_iovrl_save_vect(x,xs,desc_a,info) - import - class(psb_i_base_vect_type) :: x - integer(psb_ipk_), allocatable :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_save_vect - subroutine psi_iovrl_save_multivect(x,xs,desc_a,info) - import - class(psb_i_base_multivect_type) :: x - integer(psb_ipk_), allocatable :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_save_multivect - end interface psi_ovrl_save - - interface psi_ovrl_restore - subroutine psi_iovrl_restrr1(x,xs,desc_a,info) - import - integer(psb_ipk_), intent(inout) :: x(:) - integer(psb_ipk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_restrr1 - subroutine psi_iovrl_restrr2(x,xs,desc_a,info) - import - integer(psb_ipk_), intent(inout) :: x(:,:) - integer(psb_ipk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_restrr2 - subroutine psi_iovrl_restr_vect(x,xs,desc_a,info) - import - class(psb_i_base_vect_type) :: x - integer(psb_ipk_) :: xs(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_restr_vect - subroutine psi_iovrl_restr_multivect(x,xs,desc_a,info) - import - class(psb_i_base_multivect_type) :: x - integer(psb_ipk_) :: xs(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psi_iovrl_restr_multivect - end interface psi_ovrl_restore - -end module psi_i_mod - diff --git a/base/modules/psi_l_mod.F90 b/base/modules/psi_l_mod.F90 new file mode 100644 index 000000000..1ea56ad0a --- /dev/null +++ b/base/modules/psi_l_mod.F90 @@ -0,0 +1,42 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_l_mod + + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_mpk_, psb_epk_, psb_lpk_ + use psi_m_comm_a_mod + use psi_e_comm_a_mod + use psb_l_base_vect_mod, only : psb_l_base_vect_type + use psb_l_base_multivect_mod, only : psb_l_base_multivect_type + use psi_l_comm_v_mod + +end module psi_l_mod + diff --git a/base/modules/psi_mod.f90 b/base/modules/psi_mod.f90 index 8c061a589..55882c010 100644 --- a/base/modules/psi_mod.f90 +++ b/base/modules/psi_mod.f90 @@ -37,6 +37,7 @@ module psi_mod use psb_error_mod use psb_penv_mod use psi_i_mod + use psi_l_mod use psi_s_mod use psi_d_mod use psi_c_mod diff --git a/base/modules/psi_p2p_mod.F90 b/base/modules/psi_p2p_mod.F90 deleted file mode 100644 index 4b6149700..000000000 --- a/base/modules/psi_p2p_mod.F90 +++ /dev/null @@ -1,2348 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! - -module psi_p2p_mod - use psi_penv_mod - use psi_comm_buffers_mod - - interface psb_snd - module procedure psb_isnds, psb_isndv, psb_isndm, & - & psb_ssnds, psb_ssndv, psb_ssndm,& - & psb_dsnds, psb_dsndv, psb_dsndm,& - & psb_csnds, psb_csndv, psb_csndm,& - & psb_zsnds, psb_zsndv, psb_zsndm,& - & psb_lsnds, psb_lsndv, psb_lsndm,& - & psb_hsnds - end interface - - interface psb_rcv - module procedure psb_ircvs, psb_ircvv, psb_ircvm, & - & psb_srcvs, psb_srcvv, psb_srcvm,& - & psb_drcvs, psb_drcvv, psb_drcvm,& - & psb_crcvs, psb_crcvv, psb_crcvm,& - & psb_zrcvs, psb_zrcvv, psb_zrcvm,& - & psb_lrcvs, psb_lrcvv, psb_lrcvm,& - & psb_hrcvs - end interface - - -#if defined(LONG_INTEGERS) - interface psb_snd - module procedure psb_i4snds, psb_i4sndv, psb_i4sndm - end interface - - interface psb_rcv - module procedure psb_i4rcvs, psb_i4rcvv, psb_i4rcvm - end interface -#endif - -#if !defined(LONG_INTEGERS) - interface psb_snd - module procedure psb_i8snds, psb_i8sndv, psb_i8sndm - end interface - - interface psb_rcv - module procedure psb_i8rcvs, psb_i8rcvv, psb_i8rcvm - end interface -#endif - -#if defined(SHORT_INTEGERS) - interface psb_snd - module procedure psb_i2snds, psb_i2sndv, psb_i2sndm - end interface - - interface psb_rcv - module procedure psb_i2rcvs, psb_i2rcvv, psb_i2rcvm - end interface -#endif - - -#if defined(LONG_INTEGERS) - interface psb_snd - module procedure psb_isnds_ic, psb_isndv_ic, psb_isndm_ic, & - & psb_ssnds_ic, psb_ssndv_ic, psb_ssndm_ic,& - & psb_dsnds_ic, psb_dsndv_ic, psb_dsndm_ic,& - & psb_csnds_ic, psb_csndv_ic, psb_csndm_ic,& - & psb_zsnds_ic, psb_zsndv_ic, psb_zsndm_ic,& - & psb_lsnds_ic, psb_lsndv_ic, & - & psb_lsndm_ic, psb_hsnds_ic - end interface - - interface psb_rcv - module procedure psb_ircvs_ic, psb_ircvv_ic, psb_ircvm_ic, & - & psb_srcvs_ic, psb_srcvv_ic, psb_srcvm_ic,& - & psb_drcvs_ic, psb_drcvv_ic, psb_drcvm_ic,& - & psb_crcvs_ic, psb_crcvv_ic, psb_crcvm_ic,& - & psb_zrcvs_ic, psb_zrcvv_ic, psb_zrcvm_ic,& - & psb_lrcvs_ic, psb_lrcvv_ic, & - & psb_lrcvm_ic, psb_hrcvs_ic - end interface - -#endif - - integer(psb_mpik_), private, parameter:: psb_int_tag = 543987 - integer(psb_mpik_), private, parameter:: psb_real_tag = psb_int_tag + 1 - integer(psb_mpik_), private, parameter:: psb_double_tag = psb_real_tag + 1 - integer(psb_mpik_), private, parameter:: psb_complex_tag = psb_double_tag + 1 - integer(psb_mpik_), private, parameter:: psb_dcomplex_tag = psb_complex_tag + 1 - integer(psb_mpik_), private, parameter:: psb_logical_tag = psb_dcomplex_tag + 1 - integer(psb_mpik_), private, parameter:: psb_char_tag = psb_logical_tag + 1 - integer(psb_mpik_), private, parameter:: psb_int8_tag = psb_char_tag + 1 - integer(psb_mpik_), private, parameter:: psb_int2_tag = psb_int8_tag + 1 - integer(psb_mpik_), private, parameter:: psb_int4_tag = psb_int2_tag + 1 - - integer(psb_mpik_), parameter:: psb_int_swap_tag = psb_int_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_real_swap_tag = psb_real_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_double_swap_tag = psb_double_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_complex_swap_tag = psb_complex_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_dcomplex_swap_tag = psb_dcomplex_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_logical_swap_tag = psb_logical_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_char_swap_tag = psb_char_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_int8_swap_tag = psb_int8_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_int2_swap_tag = psb_int2_tag + psb_int_tag - integer(psb_mpik_), parameter:: psb_int4_swap_tag = psb_int4_tag + psb_int_tag - - -contains - - - ! !!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Point-to-point SND - ! - ! !!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_isnds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_int_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_isnds - - subroutine psb_isndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_int_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_isndv - - subroutine psb_isndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), intent(in), optional :: m - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_ipk_) :: i,j,k,m_,n_ - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_int_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_isndm - - subroutine psb_ssnds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_ssnds - - subroutine psb_ssndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_ssndv - - subroutine psb_ssndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), intent(in), optional :: m - real(psb_spk_), allocatable :: dat_(:) - integer(psb_ipk_) :: i,j,k,m_,n_ - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_real_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_ssndm - - - subroutine psb_dsnds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_dsnds - - subroutine psb_dsndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_dsndv - - subroutine psb_dsndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), intent(in), optional :: m - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_ipk_) :: i,j,k,m_,n_ - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_double_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_dsndm - - - subroutine psb_csnds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_csnds - - subroutine psb_csndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_csndv - - subroutine psb_csndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), intent(in), optional :: m - complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_ipk_) :: i,j,k,m_,n_ - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_complex_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_csndm - - - subroutine psb_zsnds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_zsnds - - subroutine psb_zsndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_zsndv - - subroutine psb_zsndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), intent(in), optional :: m - complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_ipk_) :: i,j,k,m_,n_ - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_dcomplex_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_zsndm - - - subroutine psb_lsnds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - logical, intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - logical, allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_lsnds - - subroutine psb_lsndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - logical, intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - logical, allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_lsndv - - subroutine psb_lsndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - logical, intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), intent(in), optional :: m - logical, allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_ipk_) :: i,j,k,m_,n_ - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_logical_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_lsndm - - - subroutine psb_hsnds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - character(len=*), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - character(len=1), allocatable :: dat_(:) - integer(psb_mpik_) :: info, l, i -#if defined(SERIAL_MPI) - ! do nothing -#else - l = len(dat) - allocate(dat_(l), stat=info) - do i=1, l - dat_(i) = dat(i:i) - end do - call psi_snd(ictxt,psb_char_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_hsnds - -#if defined(LONG_INTEGERS) - subroutine psb_i4snds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - integer(psb_mpik_), allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_i4snds - - subroutine psb_i4sndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_mpik_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_i4sndv - - subroutine psb_i4sndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_mpik_), intent(in), optional :: m - integer(psb_mpik_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_mpik_) :: i,j,k,m_,n_ - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_int4_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_i4sndm - -#endif - - -#if !defined(LONG_INTEGERS) - subroutine psb_i8snds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - integer(psb_long_int_k_), allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_i8snds - - subroutine psb_i8sndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_long_int_k_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_i8sndv - - subroutine psb_i8sndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), intent(in), optional :: m - integer(psb_long_int_k_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_ipk_) :: i,j,k,m_,n_ - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_int8_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_i8sndm - -#endif - - -#if defined(SHORT_INTEGERS) - subroutine psb_i2snds(ictxt,dat,dst) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(in) :: dat - integer(psb_mpik_), intent(in) :: dst - integer(2), allocatable :: dat_(:) - integer(psb_mpik_) :: info -#if defined(SERIAL_MPI) - ! do nothing -#else - allocate(dat_(1), stat=info) - dat_(1) = dat - call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_i2snds - - subroutine psb_i2sndv(ictxt,dat,dst) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(in) :: dat(:) - integer(psb_mpik_), intent(in) :: dst - integer(2), allocatable :: dat_(:) - integer(psb_mpik_) :: info - -#if defined(SERIAL_MPI) -#else - allocate(dat_(size(dat)), stat=info) - dat_(:) = dat(:) - call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) -#endif - - end subroutine psb_i2sndv - - subroutine psb_i2sndm(ictxt,dat,dst,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(in) :: dat(:,:) - integer(psb_mpik_), intent(in) :: dst - integer(psb_ipk_), intent(in), optional :: m - integer(2), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_ipk_) :: i,j,k,m_,n_ - -#if defined(SERIAL_MPI) -#else - if (present(m)) then - m_ = m - else - m_ = size(dat,1) - end if - n_ = size(dat,2) - allocate(dat_(m_*n_), stat=info) - k=1 - do j=1,n_ - do i=1, m_ - dat_(k) = dat(i,j) - k = k + 1 - end do - end do - call psi_snd(ictxt,psb_int2_tag,dst,dat_,psb_mesg_queue) -#endif - end subroutine psb_i2sndm - -#endif - - ! !!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Point-to-point RCV - ! - ! !!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_ircvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,psb_mpi_ipk_integer,src,psb_int_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_ircvs - - subroutine psb_ircvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),psb_mpi_ipk_integer,src,psb_int_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_ircvv - - subroutine psb_ircvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_ipk_), intent(in), optional :: m - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info, m_,n_, ld, mp_rcv_type - integer(psb_ipk_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,psb_mpi_ipk_integer,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_int_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),psb_mpi_ipk_integer,src,psb_int_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_ircvm - - - subroutine psb_srcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_srcvs - - subroutine psb_srcvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_srcvv - - subroutine psb_srcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_ipk_), intent(in), optional :: m - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info ,m_,n_, ld, mp_rcv_type - integer(psb_mpik_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,psb_mpi_r_spk_,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_real_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),psb_mpi_r_spk_,src,psb_real_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_srcvm - - - subroutine psb_drcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_drcvs - - subroutine psb_drcvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,psb_double_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_drcvv - - subroutine psb_drcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_), intent(in), optional :: m - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info ,m_,n_, ld, mp_rcv_type - integer(psb_ipk_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,psb_mpi_r_dpk_,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_double_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),psb_mpi_r_dpk_,src,& - & psb_double_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_drcvm - - - subroutine psb_crcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_crcvs - - subroutine psb_crcvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,psb_complex_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_crcvv - - subroutine psb_crcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_ipk_), intent(in), optional :: m - complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info ,m_,n_, ld, mp_rcv_type - integer(psb_ipk_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,psb_mpi_c_spk_,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_complex_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),psb_mpi_c_spk_,src,& - & psb_complex_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_crcvm - - - subroutine psb_zrcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_zrcvs - - subroutine psb_zrcvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,psb_dcomplex_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_zrcvv - - subroutine psb_zrcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_ipk_), intent(in), optional :: m - complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: info ,m_,n_, ld, mp_rcv_type - integer(psb_ipk_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,psb_mpi_c_dpk_,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_dcomplex_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),psb_mpi_c_dpk_,src,& - & psb_dcomplex_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_zrcvm - - - subroutine psb_lrcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - logical, intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,mpi_logical,src,psb_logical_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_lrcvs - - subroutine psb_lrcvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - logical, intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),mpi_logical,src,psb_logical_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_lrcvv - - subroutine psb_lrcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - logical, intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_ipk_), intent(in), optional :: m - integer(psb_mpik_) :: info ,m_,n_, ld, mp_rcv_type - integer(psb_ipk_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,mpi_logical,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_logical_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),mpi_logical,src,& - & psb_logical_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_lrcvm - - - subroutine psb_hrcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - character(len=*), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - character(len=1), allocatable :: dat_(:) - integer(psb_mpik_) :: info, l, i - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - l = len(dat) - allocate(dat_(l), stat=info) - call mpi_recv(dat_,l,mpi_character,src,psb_char_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) - do i=1, l - dat(i:i) = dat_(i) - end do - deallocate(dat_) -#endif - end subroutine psb_hrcvs - - -#if defined(LONG_INTEGERS) - - subroutine psb_i4rcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,psb_mpi_def_integer,src,psb_int4_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_i4rcvs - - subroutine psb_i4rcvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),psb_mpi_def_integer,src,psb_int4_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_i4rcvv - - subroutine psb_i4rcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_), intent(in), optional :: m - integer(psb_mpik_) :: info ,m_,n_, ld, mp_rcv_type - integer(psb_mpik_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,psb_mpi_def_integer,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_int4_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),psb_mpi_def_integer,src,& - & psb_int4_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_i4rcvm - -#endif - -#if !defined(LONG_INTEGERS) - - subroutine psb_i8rcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,psb_mpi_lng_integer,src,psb_int8_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_i8rcvs - - subroutine psb_i8rcvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),psb_mpi_lng_integer,src,psb_int8_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_i8rcvv - - subroutine psb_i8rcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_ipk_), intent(in), optional :: m - integer(psb_mpik_) :: info ,m_,n_, ld, mp_rcv_type - integer(psb_ipk_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,psb_mpi_lng_integer,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_int8_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),psb_mpi_lng_integer,src,& - & psb_int8_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_i8rcvm - -#endif - -#if defined(SHORT_INTEGERS) - - subroutine psb_i2rcvs(ictxt,dat,src) - use psi_comm_buffers_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(out) :: dat - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! do nothing -#else - call mpi_recv(dat,1,psb_mpi_def_integer2,src,psb_int2_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_i2rcvs - - subroutine psb_i2rcvv(ictxt,dat,src) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(out) :: dat(:) - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_) :: info - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) -#else - call mpi_recv(dat,size(dat),psb_mpi_def_integer2,src,psb_int2_tag,ictxt,status,info) - call psb_test_nodes(psb_mesg_queue) -#endif - - end subroutine psb_i2rcvv - - subroutine psb_i2rcvm(ictxt,dat,src,m) - use psi_comm_buffers_mod - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(out) :: dat(:,:) - integer(psb_mpik_), intent(in) :: src - integer(psb_mpik_), intent(in), optional :: m - integer(psb_mpik_) :: info , m_,n_, ld, mp_rcv_type - integer(psb_ipk_) :: i,j,k - integer(psb_mpik_) :: status(mpi_status_size) -#if defined(SERIAL_MPI) - ! What should we do here?? -#else - if (present(m)) then - m_ = m - ld = size(dat,1) - n_ = size(dat,2) - call mpi_type_vector(n_,m_,ld,psb_mpi_def_integer2,mp_rcv_type,info) - if (info == mpi_success) call mpi_type_commit(mp_rcv_type,info) - if (info == mpi_success) call mpi_recv(dat,1,mp_rcv_type,src,& - & psb_int2_tag,ictxt,status,info) - if (info == mpi_success) call mpi_type_free(mp_rcv_type,info) - else - call mpi_recv(dat,size(dat),psb_mpi_def_integer2,src,& - & psb_int2_tag,ictxt,status,info) - end if - if (info /= mpi_success) then - write(psb_err_unit,*) 'Error in psb_recv', info - end if - call psb_test_nodes(psb_mesg_queue) -#endif - end subroutine psb_i2rcvm - -#endif - - -! -! Integer * 8 aliases. -! - -#if defined(LONG_INTEGERS) - ! !!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Point-to-point SND - ! - ! !!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_isnds_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: dat - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_isnds_ic - - subroutine psb_isndv_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: dat(:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_isndv_ic - - subroutine psb_isndm_ic(ictxt,dat,dst,m) - - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(in) :: dat(:,:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_isndm_ic - - subroutine psb_ssnds_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_ssnds_ic - - subroutine psb_ssndv_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_ssndv_ic - - subroutine psb_ssndm_ic(ictxt,dat,dst,m) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(in) :: dat(:,:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_ssndm_ic - - - subroutine psb_dsnds_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_dsnds_ic - - subroutine psb_dsndv_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_dsndv_ic - - subroutine psb_dsndm_ic(ictxt,dat,dst,m) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(in) :: dat(:,:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_dsndm_ic - - - subroutine psb_csnds_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_csnds_ic - - subroutine psb_csndv_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_csndv_ic - - subroutine psb_csndm_ic(ictxt,dat,dst,m) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(in) :: dat(:,:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_csndm_ic - - - subroutine psb_zsnds_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_zsnds_ic - - subroutine psb_zsndv_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_zsndv_ic - - subroutine psb_zsndm_ic(ictxt,dat,dst,m) - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(in) :: dat(:,:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_zsndm_ic - - - subroutine psb_lsnds_ic(ictxt,dat,dst) - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(in) :: dat - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_lsnds_ic - - subroutine psb_lsndv_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(in) :: dat(:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_lsndv_ic - - subroutine psb_lsndm_ic(ictxt,dat,dst,m) - - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(in) :: dat(:,:) - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_lsndm_ic - - - subroutine psb_hsnds_ic(ictxt,dat,dst) - - integer(psb_ipk_), intent(in) :: ictxt - character(len=*), intent(in) :: dat - integer(psb_ipk_), intent(in) :: dst - - integer(psb_mpik_) :: iictxt, idst - - iictxt = ictxt - idst = dst - call psb_snd(iictxt, dat, idst) - - end subroutine psb_hsnds_ic - - - ! !!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Point-to-point RCV - ! - ! !!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_ircvs_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: dat - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_ircvs_ic - - subroutine psb_ircvv_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: dat(:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_ircvv_ic - - subroutine psb_ircvm_ic(ictxt,dat,src,m) - - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(out) :: dat(:,:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_ircvm_ic - - subroutine psb_srcvs_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_srcvs_ic - - subroutine psb_srcvv_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat(:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_srcvv_ic - - subroutine psb_srcvm_ic(ictxt,dat,src,m) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(out) :: dat(:,:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_srcvm_ic - - - subroutine psb_drcvs_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_drcvs_ic - - subroutine psb_drcvv_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat(:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_drcvv_ic - - subroutine psb_drcvm_ic(ictxt,dat,src,m) - - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(out) :: dat(:,:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_drcvm_ic - - - subroutine psb_crcvs_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_crcvs_ic - - subroutine psb_crcvv_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat(:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_crcvv_ic - - subroutine psb_crcvm_ic(ictxt,dat,src,m) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(out) :: dat(:,:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_crcvm_ic - - - subroutine psb_zrcvs_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_zrcvs_ic - - subroutine psb_zrcvv_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat(:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_zrcvv_ic - - subroutine psb_zrcvm_ic(ictxt,dat,src,m) - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(out) :: dat(:,:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_zrcvm_ic - - - subroutine psb_lrcvs_ic(ictxt,dat,src) - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(out) :: dat - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_lrcvs_ic - - subroutine psb_lrcvv_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(out) :: dat(:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_lrcvv_ic - - subroutine psb_lrcvm_ic(ictxt,dat,src,m) - - integer(psb_ipk_), intent(in) :: ictxt - logical, intent(out) :: dat(:,:) - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_lrcvm_ic - - - subroutine psb_hrcvs_ic(ictxt,dat,src) - - integer(psb_ipk_), intent(in) :: ictxt - character(len=*), intent(out) :: dat - integer(psb_ipk_), intent(in) :: src - - integer(psb_mpik_) :: iictxt, isrc - - iictxt = ictxt - isrc = src - call psb_rcv(iictxt, dat, isrc) - - end subroutine psb_hrcvs_ic - - -#endif - - -end module psi_p2p_mod diff --git a/base/modules/psi_reduce_mod.F90 b/base/modules/psi_reduce_mod.F90 deleted file mode 100644 index 597d8f8ee..000000000 --- a/base/modules/psi_reduce_mod.F90 +++ /dev/null @@ -1,5589 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -module psi_reduce_mod - use psi_penv_mod - interface psb_max - module procedure psb_imaxs, psb_imaxv, psb_imaxm,& - & psb_smaxs, psb_smaxv, psb_smaxm,& - & psb_dmaxs, psb_dmaxv, psb_dmaxm - end interface -#if defined(LONG_INTEGERS) - interface psb_max - module procedure psb_i4maxs, psb_i4maxv, psb_i4maxm - end interface -#endif -#if !defined(LONG_INTEGERS) - interface psb_max - module procedure psb_i8maxs, psb_i8maxv, psb_i8maxm - end interface -#endif - - interface psb_min - module procedure psb_imins, psb_iminv, psb_iminm,& - & psb_smins, psb_sminv, psb_sminm,& - & psb_dmins, psb_dminv, psb_dminm - end interface -#if !defined(LONG_INTEGERS) - interface psb_min - module procedure psb_i8mins, psb_i8minv, psb_i8minm - end interface -#endif -#if defined(LONG_INTEGERS) - interface psb_min - module procedure psb_i4mins, psb_i4minv, psb_i4minm - end interface -#endif - - - interface psb_amx - module procedure psb_iamxs, psb_iamxv, psb_iamxm,& - & psb_samxs, psb_samxv, psb_samxm,& - & psb_camxs, psb_camxv, psb_camxm,& - & psb_damxs, psb_damxv, psb_damxm,& - & psb_zamxs, psb_zamxv, psb_zamxm - end interface -#if !defined(LONG_INTEGERS) - interface psb_amx - module procedure psb_i8amxs, psb_i8amxv, psb_i8amxm - end interface -#endif -#if defined(LONG_INTEGERS) - interface psb_amx - module procedure psb_i4amxs, psb_i4amxv, psb_i4amxm - end interface -#endif - - interface psb_amn - module procedure psb_iamns, psb_iamnv, psb_iamnm,& - & psb_samns, psb_samnv, psb_samnm,& - & psb_camns, psb_camnv, psb_camnm,& - & psb_damns, psb_damnv, psb_damnm,& - & psb_zamns, psb_zamnv, psb_zamnm - end interface -#if defined(LONG_INTEGERS) - interface psb_amn - module procedure psb_i4amns, psb_i4amnv, psb_i4amnm - end interface -#endif -#if !defined(LONG_INTEGERS) - interface psb_amn - module procedure psb_i8amns, psb_i8amnv, psb_i8amnm - end interface -#endif - - - interface psb_sum - module procedure psb_isums, psb_isumv, psb_isumm,& - & psb_ssums, psb_ssumv, psb_ssumm,& - & psb_csums, psb_csumv, psb_csumm,& - & psb_dsums, psb_dsumv, psb_dsumm,& - & psb_zsums, psb_zsumv, psb_zsumm - end interface -#if defined(SHORT_INTEGERS) - interface psb_sum - module procedure psb_i2sums, psb_i2sumv, psb_i2summ - end interface psb_sum -#endif -#if defined(LONG_INTEGERS) - interface psb_sum - module procedure psb_i4sums, psb_i4sumv, psb_i4summ - end interface -#endif -#if !defined(LONG_INTEGERS) - interface psb_sum - module procedure psb_i8sums, psb_i8sumv, psb_i8summ - end interface -#endif - - - interface psb_nrm2 - module procedure psb_s_nrm2s, psb_s_nrm2v,& - & psb_d_nrm2s, psb_d_nrm2v - end interface - - - -#if defined(LONG_INTEGERS) - interface psb_max - module procedure psb_imaxs_ic, psb_imaxv_ic, psb_imaxm_ic,& - & psb_smaxs_ic, psb_smaxv_ic, psb_smaxm_ic,& - & psb_dmaxs_ic, psb_dmaxv_ic, psb_dmaxm_ic - end interface - - interface psb_min - module procedure psb_imins_ic, psb_iminv_ic, psb_iminm_ic,& - & psb_smins_ic, psb_sminv_ic, psb_sminm_ic,& - & psb_dmins_ic, psb_dminv_ic, psb_dminm_ic - end interface - - - interface psb_amx - module procedure psb_iamxs_ic, psb_iamxv_ic, psb_iamxm_ic,& - & psb_samxs_ic, psb_samxv_ic, psb_samxm_ic,& - & psb_camxs_ic, psb_camxv_ic, psb_camxm_ic,& - & psb_damxs_ic, psb_damxv_ic, psb_damxm_ic,& - & psb_zamxs_ic, psb_zamxv_ic, psb_zamxm_ic - end interface - - interface psb_amn - module procedure psb_iamns_ic, psb_iamnv_ic, psb_iamnm_ic,& - & psb_samns_ic, psb_samnv_ic, psb_samnm_ic,& - & psb_camns_ic, psb_camnv_ic, psb_camnm_ic,& - & psb_damns_ic, psb_damnv_ic, psb_damnm_ic,& - & psb_zamns_ic, psb_zamnv_ic, psb_zamnm_ic - end interface - - - interface psb_sum - module procedure psb_isums_ic, psb_isumv_ic, psb_isumm_ic,& - & psb_ssums_ic, psb_ssumv_ic, psb_ssumm_ic,& - & psb_csums_ic, psb_csumv_ic, psb_csumm_ic,& - & psb_dsums_ic, psb_dsumv_ic, psb_dsumm_ic,& - & psb_zsums_ic, psb_zsumv_ic, psb_zsumm_ic - end interface -#if defined(SHORT_INTEGERS) - interface psb_sum - module procedure psb_i2sums_ic, psb_i2sumv_ic, psb_i2summ_ic - end interface psb_sum -#endif - - interface psb_nrm2 - module procedure psb_s_nrm2s_ic, psb_s_nrm2v_ic,& - & psb_d_nrm2s_ic, psb_d_nrm2v_ic - end interface -#endif - - -contains - - ! !!!!!!!!!!!!!!!!!!!!!! - ! - ! Reduction operations - ! - ! !!!!!!!!!!!!!!!!!!!!!! - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! MAX - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_imaxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_ipk_) :: dat_ - integer(psb_mpik_) :: root_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_max,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_max,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_imaxs - - subroutine psb_imaxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_imaxv - - subroutine psb_imaxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_imaxm - -#if defined(LONG_INTEGERS) - subroutine psb_i4maxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_def_integer,mpi_max,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_def_integer,mpi_max,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_i4maxs - - subroutine psb_i4maxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4maxv - - subroutine psb_i4maxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4maxm - -#endif - - -#if !defined(LONG_INTEGERS) - subroutine psb_i8maxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_lng_integer,mpi_max,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_lng_integer,mpi_max,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_i8maxs - - subroutine psb_i8maxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8maxv - - subroutine psb_i8maxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8maxm - -#endif - - - subroutine psb_smaxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_max,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_max,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_smaxs - - subroutine psb_smaxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_smaxv - - subroutine psb_smaxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_smaxm - - subroutine psb_dmaxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_max,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_dmaxs - - subroutine psb_dmaxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_dmaxv - - subroutine psb_dmaxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_max,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_dmaxm - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! MIN - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_imins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_ipk_) :: dat_ - integer(psb_mpik_) :: root_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_min,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_min,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_imins - - subroutine psb_iminv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_iminv - - subroutine psb_iminm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_iminm - -#if defined(LONG_INTEGERS) - subroutine psb_i4mins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_def_integer,mpi_min,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_def_integer,mpi_min,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_i4mins - - subroutine psb_i4minv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4minv - - subroutine psb_i4minm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4minm - -#endif - - -#if !defined(LONG_INTEGERS) - subroutine psb_i8mins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_lng_integer,mpi_min,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_lng_integer,mpi_min,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_i8mins - - subroutine psb_i8minv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8minv - - subroutine psb_i8minm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8minm - -#endif - - - - subroutine psb_smins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_min,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_min,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_smins - - subroutine psb_sminv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_sminv - - subroutine psb_sminm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_sminm - - subroutine psb_dmins(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_min,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_dmins - - subroutine psb_dminv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_dminv - - subroutine psb_dminm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_min,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_dminm - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! AMX: maximum absolute value - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine psb_iamxs(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_iamx_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_iamx_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_iamxs - - subroutine psb_iamxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_iamx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_iamx_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_iamx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_iamxv - - subroutine psb_iamxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_iamx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_iamx_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_iamx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_iamxm - - -#if defined(LONG_INTEGERS) - subroutine psb_i4amxs(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_def_integer,mpi_i4amx_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_def_integer,mpi_i4amx_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_i4amxs - - subroutine psb_i4amxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_i4amx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_i4amx_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_i4amx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4amxv - - subroutine psb_i4amxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_i4amx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_i4amx_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_i4amx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4amxm - -#endif - -#if !defined(LONG_INTEGERS) - subroutine psb_i8amxs(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_lng_integer,mpi_i8amx_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_lng_integer,mpi_i8amx_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_i8amxs - - subroutine psb_i8amxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_i8amx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_i8amx_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_i8amx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8amxv - - subroutine psb_i8amxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_i8amx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_i8amx_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_i8amx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8amxm - -#endif - - - - subroutine psb_samxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samx_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_samxs - - subroutine psb_samxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_samxv - - subroutine psb_samxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_samxm - - subroutine psb_damxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damx_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_damxs - - subroutine psb_damxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_damx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_damxv - - subroutine psb_damxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_damxm - - - subroutine psb_camxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_camxs - - subroutine psb_camxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_camxv - - subroutine psb_camxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_camxm - - subroutine psb_zamxs(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_zamxs - - subroutine psb_zamxv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,& - & mpi_zamx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_zamxv - - subroutine psb_zamxm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamx_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_zamxm - - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! AMN: minimum absolute value - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_iamns(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_iamn_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_iamn_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_iamns - - subroutine psb_iamnv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_iamn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_iamn_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_iamn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_iamnv - - subroutine psb_iamnm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_iamn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_iamn_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_iamn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_iamnm - - -#if defined(LONG_INTEGERS) - subroutine psb_i4amns(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_def_integer,mpi_i4amn_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_def_integer,mpi_i4amn_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_i4amns - - subroutine psb_i4amnv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_i4amn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_i4amn_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_i4amn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4amnv - - subroutine psb_i4amnm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_mpik_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_i4amn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_i4amn_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_i4amn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4amnm - -#endif - -#if !defined(LONG_INTEGERS) - subroutine psb_i8amns(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_lng_integer,mpi_i8amn_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_lng_integer,mpi_i8amn_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_i8amns - - subroutine psb_i8amnv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_i8amn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_i8amn_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_i8amn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8amnv - - subroutine psb_i8amnm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_i8amn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_i8amn_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_i8amn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8amnm - -#endif - - - - subroutine psb_samns(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samn_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_samns - - subroutine psb_samnv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_samnv - - subroutine psb_samnm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_samn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_samnm - - subroutine psb_damns(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damn_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_damns - - subroutine psb_damnv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_damn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_damnv - - subroutine psb_damnm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_damn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_damnm - - - subroutine psb_camns(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_camns - - subroutine psb_camnv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_camnv - - subroutine psb_camnm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_camn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_camnm - - subroutine psb_zamns(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_zamns - - subroutine psb_zamnv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,& - & mpi_zamn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_zamnv - - subroutine psb_zamnm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_zamn_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_zamnm - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! SUM - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_isums(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_sum,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_ipk_integer,mpi_sum,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_isums - - subroutine psb_isumv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_isumv - - subroutine psb_isumm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_ipk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_ipk_integer,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_ipk_integer,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_ipk_integer,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_isumm - - -#if defined(SHORT_INTEGERS) - subroutine psb_i2sums(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(2) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_def_integer2,mpi_sum,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_def_integer2,mpi_sum,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_i2sums - - subroutine psb_i2sumv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(2), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer2,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer2,mpi_sum,root_,ictxt,info) - else - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer2,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i2sumv - - subroutine psb_i2summ(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(2), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(2), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer2,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer2,mpi_sum,root_,ictxt,info) - else - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer2,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i2summ - -#endif - - -#if defined(LONG_INTEGERS) - subroutine psb_i4sums(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_def_integer,mpi_sum,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_def_integer,mpi_sum,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_i4sums - - subroutine psb_i4sumv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,info) - dat_=dat - if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,info) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,dat_,info) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4sumv - - subroutine psb_i4summ(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_mpik_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_mpik_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_=dat - if (info == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_def_integer,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,info) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_def_integer,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,info) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_def_integer,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i4summ - -#endif - -#if !defined(LONG_INTEGERS) - subroutine psb_i8sums(ictxt,dat,root) - -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_lng_integer,mpi_sum,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif - -#endif - end subroutine psb_i8sums - - subroutine psb_i8sumv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8sumv - - subroutine psb_i8summ(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - integer(psb_long_int_k_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - integer(psb_long_int_k_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - if (iinfo == psb_success_) call mpi_allreduce(dat_,dat,size(dat),& - & psb_mpi_lng_integer,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_=dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_lng_integer,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_i8summ - -#endif - - - - subroutine psb_ssums(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_ssums - - subroutine psb_ssumv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_ssumv - - subroutine psb_ssumm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_ssumm - - subroutine psb_dsums(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_dsums - - subroutine psb_dsumv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_dsumv - - subroutine psb_dsumm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_dsumm - - - subroutine psb_csums(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_csums - - subroutine psb_csumv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_csumv - - subroutine psb_csumm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_spk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_spk_,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_csumm - - subroutine psb_zsums(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_zsums - - subroutine psb_zsumv(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,& - & mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_zsumv - - subroutine psb_zsumm(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - complex(psb_dpk_), allocatable :: dat_(:,:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - -#if !defined(SERIAL_MPI) - - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_)& - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat,1),size(dat,2),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) - else - call psb_realloc(1,1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_c_dpk_,mpi_sum,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_zsumm - - ! !!!!!!!!!!!! - ! - ! Norm 2 - ! - ! !!!!!!!!!!!! - subroutine psb_s_nrm2s(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_spk_,mpi_snrm2_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_spk_,mpi_snrm2_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_s_nrm2s - - subroutine psb_d_nrm2s(ictxt,dat,root) -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_) :: dat_ - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call mpi_allreduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_dnrm2_op,ictxt,info) - dat = dat_ - else - call mpi_reduce(dat,dat_,1,psb_mpi_r_dpk_,mpi_dnrm2_op,root_,ictxt,info) - if (iam == root_) dat = dat_ - endif -#endif - end subroutine psb_d_nrm2s - - subroutine psb_s_nrm2v(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_spk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_spk_,& - & mpi_snrm2_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_spk_,& - & mpi_snrm2_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_spk_,& - & mpi_snrm2_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_s_nrm2v - - subroutine psb_d_nrm2v(ictxt,dat,root) - use psb_realloc_mod -#ifdef MPI_MOD - use mpi -#endif - implicit none -#ifdef MPI_H - include 'mpif.h' -#endif - integer(psb_mpik_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_mpik_), intent(in), optional :: root - integer(psb_mpik_) :: root_ - real(psb_dpk_), allocatable :: dat_(:) - integer(psb_mpik_) :: iam, np, info - integer(psb_ipk_) :: iinfo - - -#if !defined(SERIAL_MPI) - call psb_info(ictxt,iam,np) - - if (present(root)) then - root_ = root - else - root_ = -1 - endif - if (root_ == -1) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - if (iinfo == psb_success_) & - & call mpi_allreduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_dnrm2_op,ictxt,info) - else - if (iam == root_) then - call psb_realloc(size(dat),dat_,iinfo) - dat_ = dat - call mpi_reduce(dat_,dat,size(dat),psb_mpi_r_dpk_,& - & mpi_dnrm2_op,root_,ictxt,info) - else - call psb_realloc(1,dat_,iinfo) - call mpi_reduce(dat,dat_,size(dat),psb_mpi_r_dpk_,& - & mpi_dnrm2_op,root_,ictxt,info) - end if - endif -#endif - end subroutine psb_d_nrm2v - -#if defined(LONG_INTEGERS) - - subroutine psb_imaxs_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - - end subroutine psb_imaxs_ic - - subroutine psb_imaxv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_imaxv_ic - - subroutine psb_imaxm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_imaxm_ic - - - subroutine psb_smaxs_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_smaxs_ic - - subroutine psb_smaxv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_smaxv_ic - - subroutine psb_smaxm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_smaxm_ic - - subroutine psb_dmaxs_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_dmaxs_ic - - subroutine psb_dmaxv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_dmaxv_ic - - subroutine psb_dmaxm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_max(ictxt_,dat,root_) - else - call psb_max(ictxt_,dat) - end if - end subroutine psb_dmaxm_ic - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! MIN - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_imins_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_imins_ic - - subroutine psb_iminv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_iminv_ic - - subroutine psb_iminm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_iminm_ic - - - subroutine psb_smins_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_smins_ic - - subroutine psb_sminv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_sminv_ic - - subroutine psb_sminm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_sminm_ic - - subroutine psb_dmins_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_dmins_ic - - subroutine psb_dminv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_dminv_ic - - subroutine psb_dminm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_min(ictxt_,dat,root_) - else - call psb_min(ictxt_,dat) - end if - end subroutine psb_dminm_ic - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! AMX: maximum absolute value - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - subroutine psb_iamxs_ic(ictxt,dat,root) - - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_iamxs_ic - - subroutine psb_iamxv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_iamxv_ic - - subroutine psb_iamxm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_iamxm_ic - - - - subroutine psb_samxs_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_samxs_ic - - subroutine psb_samxv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_samxv_ic - - subroutine psb_samxm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_samxm_ic - - subroutine psb_damxs_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_damxs_ic - - subroutine psb_damxv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_damxv_ic - - subroutine psb_damxm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_damxm_ic - - - subroutine psb_camxs_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_camxs_ic - - subroutine psb_camxv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_camxv_ic - - subroutine psb_camxm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_camxm_ic - - subroutine psb_zamxs_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_zamxs_ic - - subroutine psb_zamxv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_zamxv_ic - - subroutine psb_zamxm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amx(ictxt_,dat,root_) - else - call psb_amx(ictxt_,dat) - end if - end subroutine psb_zamxm_ic - - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! AMN: minimum absolute value - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_iamns_ic(ictxt,dat,root) - - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_iamns_ic - - subroutine psb_iamnv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_iamnv_ic - - subroutine psb_iamnm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_iamnm_ic - - - - - subroutine psb_samns_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_samns_ic - - subroutine psb_samnv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_samnv_ic - - subroutine psb_samnm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_samnm_ic - - subroutine psb_damns_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_damns_ic - - subroutine psb_damnv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_damnv_ic - - subroutine psb_damnm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_damnm_ic - - - subroutine psb_camns_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_camns_ic - - subroutine psb_camnv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_camnv_ic - - subroutine psb_camnm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_camnm_ic - - subroutine psb_zamns_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_zamns_ic - - subroutine psb_zamnv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_zamnv_ic - - subroutine psb_zamnm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_amn(ictxt_,dat,root_) - else - call psb_amn(ictxt_,dat) - end if - end subroutine psb_zamnm_ic - - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! SUM - ! - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - subroutine psb_isums_ic(ictxt,dat,root) - - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_isums_ic - - subroutine psb_isumv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_isumv_ic - - subroutine psb_isumm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(psb_ipk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_isumm_ic - -#if defined(SHORT_INTEGERS) - subroutine psb_i2sums_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(2), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2sums_ic - - subroutine psb_i2sumv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(2), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2sumv_ic - - subroutine psb_i2summ_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - integer(2), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_i2summ_ic - -#endif - - - - - subroutine psb_ssums_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_ssums_ic - - subroutine psb_ssumv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_ssumv_ic - - subroutine psb_ssumm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_ssumm_ic - - subroutine psb_dsums_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_dsums_ic - - subroutine psb_dsumv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_dsumv_ic - - subroutine psb_dsumm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_dsumm_ic - - - subroutine psb_csums_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_csums_ic - - subroutine psb_csumv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_csumv_ic - - subroutine psb_csumm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_spk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_csumm_ic - - subroutine psb_zsums_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_zsums_ic - - subroutine psb_zsumv_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_zsumv_ic - - subroutine psb_zsumm_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - complex(psb_dpk_), intent(inout) :: dat(:,:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_sum(ictxt_,dat,root_) - else - call psb_sum(ictxt_,dat) - end if - end subroutine psb_zsumm_ic - - ! !!!!!!!!!!!! - ! - ! Norm 2 - ! - ! !!!!!!!!!!!! - subroutine psb_s_nrm2s_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_nrm2(ictxt_,dat,root_) - else - call psb_nrm2(ictxt_,dat) - end if - end subroutine psb_s_nrm2s_ic - - subroutine psb_d_nrm2s_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_nrm2(ictxt_,dat,root_) - else - call psb_nrm2(ictxt_,dat) - end if - end subroutine psb_d_nrm2s_ic - - subroutine psb_s_nrm2v_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_spk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_nrm2(ictxt_,dat,root_) - else - call psb_nrm2(ictxt_,dat) - end if - end subroutine psb_s_nrm2v_ic - - subroutine psb_d_nrm2v_ic(ictxt,dat,root) - implicit none - integer(psb_ipk_), intent(in) :: ictxt - real(psb_dpk_), intent(inout) :: dat(:) - integer(psb_ipk_), intent(in), optional :: root - integer(psb_mpik_) :: ictxt_, root_ - - ictxt_ = ictxt - if (present(root)) then - root_ = root - call psb_nrm2(ictxt_,dat,root_) - else - call psb_nrm2(ictxt_,dat) - end if - end subroutine psb_d_nrm2v_ic - -#endif -end module psi_reduce_mod diff --git a/base/modules/psi_s_mod.F90 b/base/modules/psi_s_mod.F90 new file mode 100644 index 000000000..cac4d0f6d --- /dev/null +++ b/base/modules/psi_s_mod.F90 @@ -0,0 +1,41 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_s_mod + + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_spk_, psb_i_base_vect_type + use psi_s_comm_a_mod + use psb_s_base_vect_mod, only : psb_s_base_vect_type + use psb_s_base_multivect_mod, only : psb_s_base_multivect_type + use psi_s_comm_v_mod + +end module psi_s_mod + diff --git a/base/modules/psi_z_mod.F90 b/base/modules/psi_z_mod.F90 new file mode 100644 index 000000000..dc102323f --- /dev/null +++ b/base/modules/psi_z_mod.F90 @@ -0,0 +1,41 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +module psi_z_mod + + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_dpk_, psb_i_base_vect_type + use psi_z_comm_a_mod + use psb_z_base_vect_mod, only : psb_z_base_vect_type + use psb_z_base_multivect_mod, only : psb_z_base_multivect_type + use psi_z_comm_v_mod + +end module psi_z_mod + diff --git a/base/modules/serial/psb_base_mat_mod.f90 b/base/modules/serial/psb_base_mat_mod.f90 index 400854981..1c1970726 100644 --- a/base/modules/serial/psb_base_mat_mod.f90 +++ b/base/modules/serial/psb_base_mat_mod.f90 @@ -58,6 +58,15 @@ ! defined in the serial/f03/psb_base_mat_impl.f03 file ! ! +! +! We are also introducing the type psb_lbase_sparse_mat. +! The basic difference is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! +! module psb_base_mat_mod @@ -230,7 +239,7 @@ module psb_base_mat_mod ! interface function psb_base_get_nz_row(idx,a) result(res) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat integer(psb_ipk_), intent(in) :: idx class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res @@ -245,7 +254,7 @@ module psb_base_mat_mod ! interface function psb_base_get_nzeros(a) result(res) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res end function psb_base_get_nzeros @@ -260,7 +269,7 @@ module psb_base_mat_mod ! interface function psb_base_get_size(a) result(res) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_) :: res end function psb_base_get_size @@ -273,7 +282,7 @@ module psb_base_mat_mod ! interface subroutine psb_base_reinit(a,clear) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_base_reinit @@ -292,7 +301,7 @@ module psb_base_mat_mod ! interface subroutine psb_base_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat integer(psb_ipk_), intent(in) :: iout class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -332,7 +341,7 @@ module psb_base_mat_mod interface subroutine psb_base_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -362,7 +371,7 @@ module psb_base_mat_mod ! interface subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_), intent(out) :: n @@ -384,7 +393,7 @@ module psb_base_mat_mod ! interface subroutine psb_base_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat integer(psb_ipk_), intent(in) :: m,n class(psb_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -402,7 +411,7 @@ module psb_base_mat_mod ! interface subroutine psb_base_reallocate_nz(nz,a) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat integer(psb_ipk_), intent(in) :: nz class(psb_base_sparse_mat), intent(inout) :: a end subroutine psb_base_reallocate_nz @@ -415,7 +424,7 @@ module psb_base_mat_mod ! interface subroutine psb_base_free(a) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(inout) :: a end subroutine psb_base_free end interface @@ -429,12 +438,386 @@ module psb_base_mat_mod ! interface subroutine psb_base_trim(a) - import :: psb_ipk_, psb_long_int_k_, psb_base_sparse_mat + import :: psb_ipk_, psb_epk_, psb_base_sparse_mat class(psb_base_sparse_mat), intent(inout) :: a end subroutine psb_base_trim end interface + ! + !> \namespace psb_lbase_mod \class psb_lbase_sparse_mat + !! The basic data about your matrix. + !! This class is extended twice, to provide the various + !! data variations S/D/C/Z and to implement the actual + !! storage formats. The grandchild classes are then + !! encapsulated to implement the STATE design pattern. + !! We have an ambiguity in that the inner class has a + !! "state" variable; we hope the context will make it clear. + !! + !! + !! The methods associated to this class can be grouped into three sets: + !! - Fully implemented methods: some methods such as get_nrows or + !! set_nrows can be fully implemented at this level. + !! - Partially implemented methods: Some methods have an + !! implementation that is split between this level and the leaf + !! level. For example, the matrix transposition can be partially + !! done at this level (swapping of the rows and columns dimensions) + !! but it has to be completed by a method defined at the leaf level + !! (for actually transposing the row and column indices). + !! - Other methods: There are a number of methods that are defined + !! (i.e their interface is defined) but not implemented at this + !! level. This methods will be overwritten at the leaf level with + !! an actual implementation. If it is not the case, the method + !! defined at this level will raise an error. These methods are + !! defined in the serial/impl/psb_lbase_mat_impl.f90 file + !! + ! + + type :: psb_lbase_sparse_mat + !> Row size + integer(psb_lpk_), private :: m + !> Col size + integer(psb_lpk_), private :: n + !> Matrix state: + !! null: pristine; + !! build: it's being filled with entries; + !! assembled: ready to use in computations; + !! update: accepts coefficients but only + !! in already existing entries. + !! The transitions among the states are detailed in + !! psb_T_mat_mod. + integer(psb_ipk_), private :: state + !> How to treat duplicate elements when + !! transitioning from the BUILD to the ASSEMBLED state. + !! While many formats would allow for duplicate + !! entries, it is much better to constrain the matrices + !! NOT to have duplicate entries, except while in the + !! BUILD state; in our overall design, only COO matrices + !! can ever be in the BUILD state, hence all other formats + !! cannot have duplicate entries. + integer(psb_ipk_), private :: duplicate + !> Is the matrix triangular? (must also be square) + logical, private :: triangle + !> Is the matrix upper or lower? (only if triangular) + logical, private :: upper + !> Is the matrix diagonal stored or assumed unitary? (only if triangular) + logical, private :: unitd + !> Are the coefficients sorted ? + logical, private :: sorted + logical, private :: repeatable_updates=.false. + + contains + + ! == = ================================= + ! + ! Getters + ! + ! + ! == = ================================= + procedure, pass(a) :: get_nrows => psb_lbase_get_nrows + procedure, pass(a) :: get_ncols => psb_lbase_get_ncols + procedure, pass(a) :: get_nzeros => psb_lbase_get_nzeros + procedure, pass(a) :: get_nz_row => psb_lbase_get_nz_row + procedure, pass(a) :: get_size => psb_lbase_get_size + procedure, pass(a) :: get_state => psb_lbase_get_state + procedure, pass(a) :: get_dupl => psb_lbase_get_dupl + procedure, nopass :: get_fmt => psb_lbase_get_fmt + procedure, nopass :: has_update => psb_lbase_has_update + procedure, pass(a) :: is_null => psb_lbase_is_null + procedure, pass(a) :: is_bld => psb_lbase_is_bld + procedure, pass(a) :: is_upd => psb_lbase_is_upd + procedure, pass(a) :: is_asb => psb_lbase_is_asb + procedure, pass(a) :: is_sorted => psb_lbase_is_sorted + procedure, pass(a) :: is_upper => psb_lbase_is_upper + procedure, pass(a) :: is_lower => psb_lbase_is_lower + procedure, pass(a) :: is_triangle => psb_lbase_is_triangle + procedure, pass(a) :: is_unit => psb_lbase_is_unit + procedure, pass(a) :: is_by_rows => psb_lbase_is_by_rows + procedure, pass(a) :: is_by_cols => psb_lbase_is_by_cols + procedure, pass(a) :: is_repeatable_updates => psb_lbase_is_repeatable_updates + + ! == = ================================= + ! + ! Setters + ! + ! == = ================================= + procedure, pass(a) :: set_nrows => psb_lbase_set_nrows + procedure, pass(a) :: set_ncols => psb_lbase_set_ncols + procedure, pass(a) :: set_dupl => psb_lbase_set_dupl + procedure, pass(a) :: set_state => psb_lbase_set_state + procedure, pass(a) :: set_null => psb_lbase_set_null + procedure, pass(a) :: set_bld => psb_lbase_set_bld + procedure, pass(a) :: set_upd => psb_lbase_set_upd + procedure, pass(a) :: set_asb => psb_lbase_set_asb + procedure, pass(a) :: set_sorted => psb_lbase_set_sorted + procedure, pass(a) :: set_upper => psb_lbase_set_upper + procedure, pass(a) :: set_lower => psb_lbase_set_lower + procedure, pass(a) :: set_triangle => psb_lbase_set_triangle + procedure, pass(a) :: set_unit => psb_lbase_set_unit + + procedure, pass(a) :: set_repeatable_updates => psb_lbase_set_repeatable_updates + + + ! == = ================================= + ! + ! Data management + ! + ! == = ================================= + procedure, pass(a) :: get_neigh => psb_lbase_get_neigh + procedure, pass(a) :: free => psb_lbase_free + procedure, pass(a) :: asb => psb_lbase_mat_asb + procedure, pass(a) :: trim => psb_lbase_trim + procedure, pass(a) :: reinit => psb_lbase_reinit + procedure, pass(a) :: allocate_mnnz => psb_lbase_allocate_mnnz + procedure, pass(a) :: reallocate_nz => psb_lbase_reallocate_nz + generic, public :: allocate => allocate_mnnz + generic, public :: reallocate => reallocate_nz + + + procedure, pass(a) :: csgetptn => psb_lbase_csgetptn + generic, public :: csget => csgetptn + procedure, pass(a) :: print => psb_lbase_sparse_print + procedure, pass(a) :: sizeof => psb_lbase_sizeof + procedure, pass(a) :: transp_1mat => psb_lbase_transp_1mat + procedure, pass(a) :: transp_2mat => psb_lbase_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_lbase_transc_1mat + procedure, pass(a) :: transc_2mat => psb_lbase_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => psb_lbase_mat_sync + procedure, pass(a) :: is_host => psb_lbase_mat_is_host + procedure, pass(a) :: is_dev => psb_lbase_mat_is_dev + procedure, pass(a) :: is_sync => psb_lbase_mat_is_sync + procedure, pass(a) :: set_host => psb_lbase_mat_set_host + procedure, pass(a) :: set_dev => psb_lbase_mat_set_dev + procedure, pass(a) :: set_sync => psb_lbase_mat_set_sync + end type psb_lbase_sparse_mat + + !> Function: psb_lbase_get_nz_row + !! \memberof psb_lbase_sparse_mat + !! Interface for the get_nz_row method. Equivalent to: + !! count(A(idx,:)/=0) + !! \param idx The line we are interested in. + ! + interface + function psb_lbase_get_nz_row(idx,a) result(res) + import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat + integer(psb_lpk_), intent(in) :: idx + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + end function psb_lbase_get_nz_row + end interface + + ! + !> Function: psb_lbase_get_nzeros + !! \memberof psb_lbase_sparse_mat + !! Interface for the get_nzeros method. Equivalent to: + !! count(A(:,:)/=0) + ! + interface + function psb_lbase_get_nzeros(a) result(res) + import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + end function psb_lbase_get_nzeros + end interface + + !> Function get_size + !! \memberof psb_lbase_sparse_mat + !! how many items can A hold with + !! its current space allocation? + !! (as opposed to how many are + !! currently occupied) + ! + interface + function psb_lbase_get_size(a) result(res) + import :: psb_lpk_, psb_epk_, psb_lbase_sparse_mat + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + end function psb_lbase_get_size + end interface + + ! + !> Function reinit: transition state from ASB to UPDATE + !! \memberof psb_lbase_sparse_mat + !! \param clear [true] explicitly zero out coefficients. + ! + interface + subroutine psb_lbase_reinit(a,clear) + import :: psb_ipk_, psb_epk_, psb_lbase_sparse_mat + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lbase_reinit + end interface + + + ! + !> Function + !! \memberof psb_lbase_sparse_mat + !! print on file in Matrix Market format. + !! \param iout the output unit + !! \param iv(:) [none] renumber both row and column indices + !! \param head [none] a descriptive header for the matrix data + !! \param ivr(:) [none] renumbering for the rows + !! \param ivc(:) [none] renumbering for the cols + ! + interface + subroutine psb_lbase_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat + integer(psb_ipk_), intent(in) :: iout + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lbase_sparse_print + end interface + + + ! + !> Function getptn: + !! \memberof psb_lbase_sparse_mat + !! \brief Get the pattern. + !! + !! + !! Return a list of NZ pairs + !! (IA(i),JA(i)) + !! each identifying the position of a nonzero in A + !! between row indices IMIN:IMAX; + !! IA,JA are reallocated as necessary. + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param nz the number of output coefficients + !! \param ia(:) the output row indices + !! \param ja(:) the output col indices + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + ! + + interface + subroutine psb_lbase_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lbase_csgetptn + end interface + + ! + !> Function get_neigh: + !! \memberof psb_lbase_sparse_mat + !! \brief Get the neighbours. + !! + !! + !! Return a list of N indices of neighbours of index idx, + !! i.e. the indices of the nonzeros in row idx of matrix A + !! \param idx the index we are interested in + !! \param neigh(:) the list of indices, reallocated as necessary + !! \param n the number of indices returned + !! \param info return code + !! \param lev [1] find neighbours recursively for LEV levels, + !! i.e. when lev=2 find neighours of neighbours, etc. + ! + interface + subroutine psb_lbase_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_lbase_get_neigh + end interface + + ! + ! + !> Function allocate_mnnz + !! \memberof psb_lbase_sparse_mat + !! \brief Three-parameters version of allocate + !! + !! \param m number of rows + !! \param n number of cols + !! \param nz [estimated internally] number of nonzeros to allocate for + ! + interface + subroutine psb_lbase_allocate_mnnz(m,n,a,nz) + import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat + integer(psb_lpk_), intent(in) :: m,n + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lbase_allocate_mnnz + end interface + + + ! + ! + !> Function reallocate_nz + !! \memberof psb_lbase_sparse_mat + !! \brief One--parameter version of (re)allocate + !! + !! \param nz number of nonzeros to allocate for + ! + interface + subroutine psb_lbase_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat + integer(psb_lpk_), intent(in) :: nz + class(psb_lbase_sparse_mat), intent(inout) :: a + end subroutine psb_lbase_reallocate_nz + end interface + + ! + !> Function free + !! \memberof psb_lbase_sparse_mat + !! \brief destructor + ! + interface + subroutine psb_lbase_free(a) + import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat + class(psb_lbase_sparse_mat), intent(inout) :: a + end subroutine psb_lbase_free + end interface + + ! + !> Function trim + !! \memberof psb_lbase_sparse_mat + !! \brief Memory trim + !! Make sure the memory allocation of the sparse matrix is as tight as + !! possible given the actual number of nonzeros it contains. + ! + interface + subroutine psb_lbase_trim(a) + import :: psb_ipk_, psb_lpk_, psb_epk_, psb_lbase_sparse_mat + class(psb_lbase_sparse_mat), intent(inout) :: a + end subroutine psb_lbase_trim + end interface + + + interface assignment(=) + module procedure psb_base_from_lbase, psb_lbase_from_base + end interface assignment(=) + contains @@ -446,7 +829,7 @@ contains function psb_base_sizeof(a) result(res) implicit none class(psb_base_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 8 end function psb_base_sizeof @@ -897,5 +1280,499 @@ contains res = .true. end function psb_base_mat_is_sync + + + ! + !> Function sizeof + !! \memberof psb_lbase_sparse_mat + !! \brief Memory occupation in byes + ! + function psb_lbase_sizeof(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 8 + end function psb_lbase_sizeof + + ! + !> Function get_fmt + !! \memberof psb_lbase_sparse_mat + !! \brief return a short descriptive name (e.g. COO CSR etc.) + ! + function psb_lbase_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'NULL' + end function psb_lbase_get_fmt + ! + !> Function has_update + !! \memberof psb_lbase_sparse_mat + !! \brief Does the forma have the UPDATE functionality? + ! + function psb_lbase_has_update() result(res) + implicit none + logical :: res + res = .true. + end function psb_lbase_has_update + + ! + ! Standard getter functions: self-explaining. + ! + function psb_lbase_get_dupl(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: res + res = a%duplicate + end function psb_lbase_get_dupl + + + function psb_lbase_get_state(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_ipk_) :: res + res = a%state + end function psb_lbase_get_state + + function psb_lbase_get_nrows(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%m + end function psb_lbase_get_nrows + + function psb_lbase_get_ncols(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%n + end function psb_lbase_get_ncols + + subroutine psb_lbase_set_nrows(m,a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + a%m = m + end subroutine psb_lbase_set_nrows + + subroutine psb_lbase_set_ncols(n,a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + a%n = n + end subroutine psb_lbase_set_ncols + + + subroutine psb_lbase_set_state(n,a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + a%state = n + end subroutine psb_lbase_set_state + + + subroutine psb_lbase_set_dupl(n,a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + a%duplicate = n + end subroutine psb_lbase_set_dupl + + subroutine psb_lbase_set_null(a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + + a%state = psb_spmat_null_ + end subroutine psb_lbase_set_null + + subroutine psb_lbase_set_bld(a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + + a%state = psb_spmat_bld_ + end subroutine psb_lbase_set_bld + + subroutine psb_lbase_set_upd(a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + + a%state = psb_spmat_upd_ + end subroutine psb_lbase_set_upd + + subroutine psb_lbase_set_asb(a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + + a%state = psb_spmat_asb_ + end subroutine psb_lbase_set_asb + + subroutine psb_lbase_set_sorted(a,val) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + + if (present(val)) then + a%sorted = val + else + a%sorted = .true. + end if + end subroutine psb_lbase_set_sorted + + subroutine psb_lbase_set_triangle(a,val) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + + if (present(val)) then + a%triangle = val + else + a%triangle = .true. + end if + end subroutine psb_lbase_set_triangle + + subroutine psb_lbase_set_unit(a,val) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + + if (present(val)) then + a%unitd = val + else + a%unitd = .true. + end if + end subroutine psb_lbase_set_unit + + subroutine psb_lbase_set_lower(a,val) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + + if (present(val)) then + a%upper = .not.val + else + a%upper = .false. + end if + end subroutine psb_lbase_set_lower + + subroutine psb_lbase_set_upper(a,val) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + + if (present(val)) then + a%upper = val + else + a%upper = .true. + end if + end subroutine psb_lbase_set_upper + + subroutine psb_lbase_set_repeatable_updates(a,val) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: val + + if (present(val)) then + a%repeatable_updates = val + else + a%repeatable_updates = .true. + end if + end subroutine psb_lbase_set_repeatable_updates + + function psb_lbase_is_triangle(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = a%triangle + end function psb_lbase_is_triangle + + function psb_lbase_is_unit(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = a%unitd + end function psb_lbase_is_unit + + function psb_lbase_is_upper(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = a%upper + end function psb_lbase_is_upper + + function psb_lbase_is_lower(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = .not.a%upper + end function psb_lbase_is_lower + + function psb_lbase_is_null(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = (a%state == psb_spmat_null_) + end function psb_lbase_is_null + + function psb_lbase_is_bld(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = (a%state == psb_spmat_bld_) + end function psb_lbase_is_bld + + function psb_lbase_is_upd(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = (a%state == psb_spmat_upd_) + end function psb_lbase_is_upd + + function psb_lbase_is_asb(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = (a%state == psb_spmat_asb_) + end function psb_lbase_is_asb + + function psb_lbase_is_sorted(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = a%sorted + end function psb_lbase_is_sorted + + + function psb_lbase_is_by_rows(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = .false. + end function psb_lbase_is_by_rows + + function psb_lbase_is_by_cols(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = .false. + end function psb_lbase_is_by_cols + + function psb_lbase_is_repeatable_updates(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + res = a%repeatable_updates + end function psb_lbase_is_repeatable_updates + + + ! + ! TRANSP: note sorted=.false. + ! better invoke a fix() too many than + ! regret it later... + ! + subroutine psb_lbase_transp_2mat(a,b) + implicit none + + class(psb_lbase_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + b%m = a%n + b%n = a%m + b%state = a%state + b%duplicate = a%duplicate + b%triangle = a%triangle + b%unitd = a%unitd + b%upper = .not.a%upper + b%sorted = .false. + b%repeatable_updates = .false. + + end subroutine psb_lbase_transp_2mat + + subroutine psb_lbase_transc_2mat(a,b) + implicit none + + class(psb_lbase_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + + b%m = a%n + b%n = a%m + b%state = a%state + b%duplicate = a%duplicate + b%triangle = a%triangle + b%unitd = a%unitd + b%upper = .not.a%upper + b%sorted = .false. + b%repeatable_updates = .false. + + end subroutine psb_lbase_transc_2mat + + subroutine psb_lbase_transp_1mat(a) + implicit none + + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: itmp + + itmp = a%m + a%m = a%n + a%n = itmp + a%state = a%state + a%duplicate = a%duplicate + a%triangle = a%triangle + a%unitd = a%unitd + a%upper = .not.a%upper + a%sorted = .false. + a%repeatable_updates = .false. + + end subroutine psb_lbase_transp_1mat + + subroutine psb_lbase_transc_1mat(a) + implicit none + + class(psb_lbase_sparse_mat), intent(inout) :: a + + call a%transp() + end subroutine psb_lbase_transc_1mat + + + + ! + !> Function base_asb: + !! \memberof psb_lbase_sparse_mat + !! \brief Sync: base version calls sync and the set_asb. + !! + ! + subroutine psb_lbase_mat_asb(a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + + call a%sync() + call a%set_asb() + end subroutine psb_lbase_mat_asb + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_lbase_sparse_mat + !! \brief Sync: base version is a no-op. + !! + ! + subroutine psb_lbase_mat_sync(a) + implicit none + class(psb_lbase_sparse_mat), target, intent(in) :: a + + end subroutine psb_lbase_mat_sync + + ! + !> Function base_set_host: + !! \memberof psb_lbase_sparse_mat + !! \brief Set_host: base version is a no-op. + !! + ! + subroutine psb_lbase_mat_set_host(a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + + end subroutine psb_lbase_mat_set_host + + ! + !> Function base_set_dev: + !! \memberof psb_lbase_sparse_mat + !! \brief Set_dev: base version is a no-op. + !! + ! + subroutine psb_lbase_mat_set_dev(a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + + end subroutine psb_lbase_mat_set_dev + + ! + !> Function base_set_sync: + !! \memberof psb_lbase_sparse_mat + !! \brief Set_sync: base version is a no-op. + !! + ! + subroutine psb_lbase_mat_set_sync(a) + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + + end subroutine psb_lbase_mat_set_sync + + ! + !> Function base_is_dev: + !! \memberof psb_lbase_sparse_mat + !! \brief Is matrix on eaternal device . + !! + ! + function psb_lbase_mat_is_dev(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + + res = .false. + end function psb_lbase_mat_is_dev + + ! + !> Function base_is_host + !! \memberof psb_lbase_sparse_mat + !! \brief Is matrix on standard memory . + !! + ! + function psb_lbase_mat_is_host(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + + res = .true. + end function psb_lbase_mat_is_host + + ! + !> Function base_is_sync + !! \memberof psb_lbase_sparse_mat + !! \brief Is matrix on sync . + !! + ! + function psb_lbase_mat_is_sync(a) result(res) + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + logical :: res + + res = .true. + end function psb_lbase_mat_is_sync + + + subroutine psb_lbase_from_base(lb,ib) + type(psb_lbase_sparse_mat), intent(inout) :: lb + type(psb_base_sparse_mat), intent(in) :: ib + + lb%m = ib%m + lb%n = ib%n + lb%state = ib%state + lb%duplicate = ib%duplicate + lb%triangle = ib%triangle + lb%unitd = ib%unitd + lb%upper = ib%upper + lb%sorted = ib%sorted + lb%repeatable_updates = ib%repeatable_updates + + end subroutine psb_lbase_from_base + + subroutine psb_base_from_lbase(ib,lb) + type(psb_base_sparse_mat), intent(inout) :: ib + type(psb_lbase_sparse_mat), intent(in) :: lb + + ib%m = lb%m + ib%n = lb%n + ib%state = lb%state + ib%duplicate = lb%duplicate + ib%triangle = lb%triangle + ib%unitd = lb%unitd + ib%upper = lb%upper + ib%sorted = lb%sorted + ib%repeatable_updates = lb%repeatable_updates + + end subroutine psb_base_from_lbase + end module psb_base_mat_mod diff --git a/base/modules/serial/psb_c_base_mat_mod.f90 b/base/modules/serial/psb_c_base_mat_mod.f90 index 50b46ddc4..3063713cb 100644 --- a/base/modules/serial/psb_c_base_mat_mod.f90 +++ b/base/modules/serial/psb_c_base_mat_mod.f90 @@ -79,6 +79,18 @@ module psb_c_base_mat_mod procedure, pass(a) :: clone => psb_c_base_clone procedure, pass(a) :: make_nonunit => psb_c_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_c_base_clean_zeros + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_lcoo => psb_c_base_cp_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_c_base_cp_from_lcoo + procedure, pass(a) :: cp_to_lfmt => psb_c_base_cp_to_lfmt + procedure, pass(a) :: cp_from_lfmt => psb_c_base_cp_from_lfmt + procedure, pass(a) :: mv_to_lcoo => psb_c_base_mv_to_lcoo + procedure, pass(a) :: mv_from_lcoo => psb_c_base_mv_from_lcoo + procedure, pass(a) :: mv_to_lfmt => psb_c_base_mv_to_lfmt + procedure, pass(a) :: mv_from_lfmt => psb_c_base_mv_from_lfmt + ! ! Transpose methods: defined here but not implemented. @@ -115,7 +127,10 @@ module psb_c_base_mat_mod procedure, pass(a) :: aclsum => psb_c_base_aclsum end type psb_c_base_sparse_mat - + private :: c_base_mat_sync, c_base_mat_is_host, c_base_mat_is_dev, & + & c_base_mat_is_sync, c_base_mat_set_host, c_base_mat_set_dev,& + & c_base_mat_set_sync + !> \namespace psb_base_mod \class psb_c_coo_sparse_mat !! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat !! @@ -155,6 +170,13 @@ module psb_c_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_c_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_c_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_c_mv_coo_from_fmt + + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_lcoo => psb_c_cp_coo_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_c_cp_coo_from_lcoo + procedure, pass(a) :: csput_a => psb_c_coo_csput_a procedure, pass(a) :: get_diag => psb_c_coo_get_diag procedure, pass(a) :: csgetrow => psb_c_coo_csgetrow @@ -212,6 +234,183 @@ module psb_c_base_mat_mod & c_coo_transp_1mat, c_coo_transc_1mat + !> \namespace psb_base_mod \class psb_lc_base_sparse_mat + !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat + !! The psb_lc_base_sparse_mat type, extending psb_base_sparse_mat, + !! defines a middle level complex(psb_spk_) sparse matrix object. + !! This class object itself does not have any additional members + !! with respect to those of the base class. Most methods cannot be fully + !! implemented at this level, but we can define the interface for the + !! computational methods requiring the knowledge of the underlying + !! field, such as the matrix-vector product; this interface is defined, + !! but is supposed to be overridden at the leaf level. + !! + !! About the method MOLD: this has been defined for those compilers + !! not yet supporting ALLOCATE( ...,MOLD=...); it's otherwise silly to + !! duplicate "by hand" what is specified in the language (in this case F2008) + !! + type, extends(psb_lbase_sparse_mat) :: psb_lc_base_sparse_mat + contains + ! + ! Data management methods: defined here, but (mostly) not implemented. + ! + procedure, pass(a) :: csput_a => psb_lc_base_csput_a + procedure, pass(a) :: csput_v => psb_lc_base_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetrow => psb_lc_base_csgetrow + procedure, pass(a) :: csgetblk => psb_lc_base_csgetblk + procedure, pass(a) :: get_diag => psb_lc_base_get_diag + generic, public :: csget => csgetrow, csgetblk + procedure, pass(a) :: tril => psb_lc_base_tril + procedure, pass(a) :: triu => psb_lc_base_triu + procedure, pass(a) :: csclip => psb_lc_base_csclip + procedure, pass(a) :: cp_to_coo => psb_lc_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_lc_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lc_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lc_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lc_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_lc_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lc_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lc_base_mv_from_fmt + procedure, pass(a) :: mold => psb_lc_base_mold + procedure, pass(a) :: clone => psb_lc_base_clone + procedure, pass(a) :: make_nonunit => psb_lc_base_make_nonunit + procedure, pass(a) :: clean_zeros => psb_lc_base_clean_zeros + + ! + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_lc_base_scals + procedure, pass(a) :: scalv => psb_lc_base_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: maxval => psb_lc_base_maxval + procedure, pass(a) :: spnmi => psb_lc_base_csnmi + procedure, pass(a) :: spnm1 => psb_lc_base_csnm1 + procedure, pass(a) :: rowsum => psb_lc_base_rowsum + procedure, pass(a) :: arwsum => psb_lc_base_arwsum + procedure, pass(a) :: colsum => psb_lc_base_colsum + procedure, pass(a) :: aclsum => psb_lc_base_aclsum + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_icoo => psb_lc_base_cp_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_lc_base_cp_from_icoo + procedure, pass(a) :: cp_to_ifmt => psb_lc_base_cp_to_ifmt + procedure, pass(a) :: cp_from_ifmt => psb_lc_base_cp_from_ifmt + procedure, pass(a) :: mv_to_icoo => psb_lc_base_mv_to_icoo + procedure, pass(a) :: mv_from_icoo => psb_lc_base_mv_from_icoo + procedure, pass(a) :: mv_to_ifmt => psb_lc_base_mv_to_ifmt + procedure, pass(a) :: mv_from_ifmt => psb_lc_base_mv_from_ifmt + + ! + ! Transpose methods: defined here but not implemented. + ! + procedure, pass(a) :: transp_1mat => psb_lc_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_lc_base_transp_2mat + procedure, pass(a) :: transc_1mat => psb_lc_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_lc_base_transc_2mat + + end type psb_lc_base_sparse_mat + + private :: lc_base_mat_sync, lc_base_mat_is_host, lc_base_mat_is_dev, & + & lc_base_mat_is_sync, lc_base_mat_set_host, lc_base_mat_set_dev,& + & lc_base_mat_set_sync + + !> \namespace psb_base_mod \class psb_lc_coo_sparse_mat + !! \extends psb_lc_base_mat_mod::psb_lc_base_sparse_mat + !! + !! psb_lc_coo_sparse_mat type and the related methods. This is the + !! reference type for all the format transitions, copies and mv unless + !! methods are implemented that allow the direct transition from one + !! format to another. It is defined here since all other classes must + !! refer to it per the MEDIATOR design pattern. + !! + type, extends(psb_lc_base_sparse_mat) :: psb_lc_coo_sparse_mat + !> Number of nonzeros. + integer(psb_lpk_) :: nnz + !> Row indices. + integer(psb_lpk_), allocatable :: ia(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + complex(psb_spk_), allocatable :: val(:) + + integer, private :: sort_status=psb_unsorted_ + + contains + ! + ! Data management methods. + ! + procedure, pass(a) :: get_size => lc_coo_get_size + procedure, pass(a) :: get_nzeros => lc_coo_get_nzeros + procedure, nopass :: get_fmt => lc_coo_get_fmt + procedure, pass(a) :: sizeof => lc_coo_sizeof + procedure, pass(a) :: reallocate_nz => psb_lc_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_lc_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_lc_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => psb_lc_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lc_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lc_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lc_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => psb_lc_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lc_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lc_mv_coo_from_fmt + procedure, pass(a) :: cp_to_icoo => psb_lc_cp_coo_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_lc_cp_coo_from_icoo + + procedure, pass(a) :: csput_a => psb_lc_coo_csput_a + procedure, pass(a) :: get_diag => psb_lc_coo_get_diag + procedure, pass(a) :: csgetrow => psb_lc_coo_csgetrow + procedure, pass(a) :: csgetptn => psb_lc_coo_csgetptn + procedure, pass(a) :: reinit => psb_lc_coo_reinit + procedure, pass(a) :: get_nz_row => psb_lc_coo_get_nz_row + procedure, pass(a) :: fix => psb_lc_fix_coo + procedure, pass(a) :: trim => psb_lc_coo_trim + procedure, pass(a) :: clean_zeros => psb_lc_coo_clean_zeros + procedure, pass(a) :: print => psb_lc_coo_print + procedure, pass(a) :: free => lc_coo_free + procedure, pass(a) :: mold => psb_lc_coo_mold + procedure, pass(a) :: is_sorted => lc_coo_is_sorted + procedure, pass(a) :: is_by_rows => lc_coo_is_by_rows + procedure, pass(a) :: is_by_cols => lc_coo_is_by_cols + procedure, pass(a) :: set_by_rows => lc_coo_set_by_rows + procedure, pass(a) :: set_by_cols => lc_coo_set_by_cols + procedure, pass(a) :: set_sort_status => lc_coo_set_sort_status + procedure, pass(a) :: get_sort_status => lc_coo_get_sort_status + + + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_lc_coo_scals + procedure, pass(a) :: scalv => psb_lc_coo_scal + procedure, pass(a) :: maxval => psb_lc_coo_maxval + procedure, pass(a) :: spnmi => psb_lc_coo_csnmi + procedure, pass(a) :: spnm1 => psb_lc_coo_csnm1 + procedure, pass(a) :: rowsum => psb_lc_coo_rowsum + procedure, pass(a) :: arwsum => psb_lc_coo_arwsum + procedure, pass(a) :: colsum => psb_lc_coo_colsum + procedure, pass(a) :: aclsum => psb_lc_coo_aclsum + + ! + ! This is COO specific + ! + procedure, pass(a) :: set_nzeros => lc_coo_set_nzeros + + ! + ! Transpose methods. These are the base of all + ! indirection in transpose, together with conversions + ! they are sufficient for all cases. + ! + procedure, pass(a) :: transp_1mat => lc_coo_transp_1mat + procedure, pass(a) :: transc_1mat => lc_coo_transc_1mat + + + end type psb_lc_coo_sparse_mat + + private :: lc_coo_get_nzeros, lc_coo_set_nzeros, & + & lc_coo_get_fmt, lc_coo_free, lc_coo_sizeof, & + & lc_coo_transp_1mat, lc_coo_transc_1mat + ! == ================= ! @@ -257,7 +456,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -268,8 +467,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_, psb_c_base_vect_type,& - & psb_i_base_vect_type + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -314,7 +512,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -324,7 +522,7 @@ module psb_c_base_mat_mod logical, intent(in), optional :: append integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale, chksz + logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_c_base_csgetrow end interface @@ -353,7 +551,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -391,7 +589,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -432,7 +630,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -476,7 +674,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -499,7 +697,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_get_diag(a,d,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -518,7 +716,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_mold(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_long_int_k_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -540,7 +738,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_clone(a,b, info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_long_int_k_ + import implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), allocatable, intent(inout) :: b @@ -559,7 +757,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_make_nonunit(a) - import :: psb_c_base_sparse_mat + import implicit none class(psb_c_base_sparse_mat), intent(inout) :: a end subroutine psb_c_base_make_nonunit @@ -576,7 +774,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_cp_to_coo(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -593,7 +791,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_cp_from_coo(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -611,7 +809,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_cp_to_fmt(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -629,7 +827,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_cp_from_fmt(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -646,7 +844,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_mv_to_coo(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -663,7 +861,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_mv_from_coo(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -681,7 +879,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_mv_to_fmt(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -699,12 +897,153 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_mv_from_fmt(a,b,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_mv_from_fmt end interface + ! + !> Function cp_to_coo: + !! \memberof psb_c_base_sparse_mat + !! \brief Copy and convert to psb_c_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_c_base_cp_to_lcoo(a,b,info) + import + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_cp_to_lcoo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_c_base_sparse_mat + !! \brief Copy and convert from psb_c_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_c_base_cp_from_lcoo(a,b,info) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_cp_from_lcoo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_c_base_sparse_mat + !! \brief Copy and convert to a class(psb_c_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_c_base_cp_to_lfmt(a,b,info) + import + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_cp_to_lfmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_c_base_sparse_mat + !! \brief Copy and convert from a class(psb_c_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_c_base_cp_from_lfmt(a,b,info) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_cp_from_lfmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_c_base_sparse_mat + !! \brief Convert to psb_c_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_c_base_mv_to_lcoo(a,b,info) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_mv_to_lcoo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_c_base_sparse_mat + !! \brief Convert from psb_c_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_c_base_mv_from_lcoo(a,b,info) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_mv_from_lcoo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_c_base_sparse_mat + !! \brief Convert to a class(psb_c_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_c_base_mv_to_lfmt(a,b,info) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_mv_to_lfmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_c_base_sparse_mat + !! \brief Convert from a class(psb_c_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_c_base_mv_from_lfmt(a,b,info) + import + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_mv_from_lfmt + end interface + + ! !> !! \memberof psb_c_base_sparse_mat @@ -712,7 +1051,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_clean_zeros(a, info) - import :: psb_ipk_, psb_c_base_sparse_mat + import class(psb_c_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_clean_zeros @@ -728,7 +1067,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_transp_2mat(a,b) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_c_base_transp_2mat @@ -744,7 +1083,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_transc_2mat(a,b) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_c_base_transc_2mat @@ -759,7 +1098,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_transp_1mat(a) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a end subroutine psb_c_base_transp_1mat end interface @@ -773,7 +1112,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_transc_1mat(a) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a end subroutine psb_c_base_transc_1mat end interface @@ -798,7 +1137,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -826,7 +1165,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -861,7 +1200,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_vect_mv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_, psb_c_base_vect_type + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x @@ -893,7 +1232,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -928,7 +1267,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -963,7 +1302,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_, psb_c_base_vect_type + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x, y @@ -995,7 +1334,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1028,7 +1367,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1062,7 +1401,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_,psb_c_base_vect_type + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta class(psb_c_base_vect_type), intent(inout) :: x,y @@ -1082,7 +1421,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_scals(d,a,info) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1100,7 +1439,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_scal(d,a,info,side) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1116,7 +1455,7 @@ module psb_c_base_mat_mod ! interface function psb_c_base_maxval(a) result(res) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_base_maxval @@ -1131,7 +1470,7 @@ module psb_c_base_mat_mod ! interface function psb_c_base_csnmi(a) result(res) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_base_csnmi @@ -1146,7 +1485,7 @@ module psb_c_base_mat_mod ! interface function psb_c_base_csnm1(a) result(res) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_base_csnm1 @@ -1162,7 +1501,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_rowsum(d,a) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_base_rowsum @@ -1176,7 +1515,7 @@ module psb_c_base_mat_mod !! interface subroutine psb_c_base_arwsum(d,a) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_base_arwsum @@ -1192,7 +1531,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_base_colsum(d,a) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_base_colsum @@ -1206,7 +1545,7 @@ module psb_c_base_mat_mod !! interface subroutine psb_c_base_aclsum(d,a) - import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_ + import class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_base_aclsum @@ -1226,7 +1565,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_coo_reallocate_nz(nz,a) - import :: psb_ipk_, psb_c_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_c_coo_sparse_mat), intent(inout) :: a end subroutine psb_c_coo_reallocate_nz @@ -1239,7 +1578,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_coo_reinit(a,clear) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_c_coo_reinit @@ -1251,7 +1590,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_coo_trim(a) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a end subroutine psb_c_coo_trim end interface @@ -1262,7 +1601,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_coo_clean_zeros(a,info) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_clean_zeros @@ -1275,7 +1614,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_c_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -1287,7 +1626,7 @@ module psb_c_base_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_c_coo_mold(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ + import class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -1309,7 +1648,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_c_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -1330,7 +1669,7 @@ module psb_c_base_mat_mod ! interface function psb_c_coo_get_nz_row(idx,a) result(res) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res @@ -1354,11 +1693,12 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import :: psb_ipk_, psb_spk_ + import integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) complex(psb_spk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout, info + integer(psb_ipk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_c_fix_coo_inner end interface @@ -1373,7 +1713,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_fix_coo(a,info,idir) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir @@ -1385,7 +1725,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_to_coo interface subroutine psb_c_cp_coo_to_coo(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1397,12 +1737,35 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo interface subroutine psb_c_cp_coo_from_coo(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_c_cp_coo_from_coo end interface + !> + !! \memberof psb_c_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_c_base_cp_to_coo + interface + subroutine psb_c_cp_coo_to_lcoo(a,b,info) + import + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_cp_coo_to_lcoo + end interface + + !> + !! \memberof psb_c_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo + interface + subroutine psb_c_cp_coo_from_lcoo(a,b,info) + import + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_cp_coo_from_lcoo + end interface !> !! \memberof psb_c_coo_sparse_mat @@ -1410,7 +1773,7 @@ module psb_c_base_mat_mod !! interface subroutine psb_c_cp_coo_to_fmt(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1423,7 +1786,7 @@ module psb_c_base_mat_mod !! interface subroutine psb_c_cp_coo_from_fmt(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -1435,7 +1798,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_to_coo interface subroutine psb_c_mv_coo_to_coo(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1447,7 +1810,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_from_coo interface subroutine psb_c_mv_coo_from_coo(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1459,7 +1822,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_to_fmt interface subroutine psb_c_mv_coo_to_fmt(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1471,7 +1834,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_from_fmt interface subroutine psb_c_mv_coo_from_fmt(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_coo_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1480,7 +1843,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_coo_cp_from(a,b) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(inout) :: a type(psb_c_coo_sparse_mat), intent(in) :: b end subroutine psb_c_coo_cp_from @@ -1488,7 +1851,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_coo_mv_from(a,b) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(inout) :: a type(psb_c_coo_sparse_mat), intent(inout) :: b end subroutine psb_c_coo_mv_from @@ -1513,7 +1876,7 @@ module psb_c_base_mat_mod ! interface subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -1529,7 +1892,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1548,7 +1911,7 @@ module psb_c_base_mat_mod interface subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1567,7 +1930,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cssv interface subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1580,7 +1943,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cssm interface subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1594,7 +1957,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csmv interface subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -1608,7 +1971,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csmm interface subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -1623,7 +1986,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_maxval interface function psb_c_coo_maxval(a) result(res) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_coo_maxval @@ -1634,7 +1997,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csnmi interface function psb_c_coo_csnmi(a) result(res) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_coo_csnmi @@ -1645,7 +2008,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csnm1 interface function psb_c_coo_csnm1(a) result(res) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_coo_csnm1 @@ -1656,7 +2019,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_rowsum interface subroutine psb_c_coo_rowsum(d,a) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_coo_rowsum @@ -1666,7 +2029,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_arwsum interface subroutine psb_c_coo_arwsum(d,a) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_coo_arwsum @@ -1677,7 +2040,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_colsum interface subroutine psb_c_coo_colsum(d,a) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_coo_colsum @@ -1688,7 +2051,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_aclsum interface subroutine psb_c_coo_aclsum(d,a) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_coo_aclsum @@ -1699,7 +2062,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_get_diag interface subroutine psb_c_coo_get_diag(a,d,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1711,7 +2074,7 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_scal interface subroutine psb_c_coo_scal(d,a,info,side) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1724,13 +2087,1351 @@ module psb_c_base_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_scals interface subroutine psb_c_coo_scals(d,a,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_coo_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_scals end interface + ! == ================= + ! + ! BASE interfaces + ! + ! == ================= + + !> Function csput: + !! \memberof psb_lc_base_sparse_mat + !! \brief Insert coefficients. + !! + !! + !! Given a list of NZ triples + !! (IA(i),JA(i),VAL(i)) + !! record a new coefficient in A such that + !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). + !! + !! The internal components IA,JA,VAL are reallocated as necessary. + !! Constraints: + !! - If the matrix A is in the BUILD state, then the method will + !! only work for COO matrices, all other format will throw an error. + !! In this case coefficients are queued inside A for further processing. + !! - If the matrix A is in the UPDATE state, then it can be in any format; + !! the update operation will perform either + !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ) + !! or + !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) + !! according to the value of DUPLICATE. + !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! + !! \param nz number of triples in input + !! \param ia(:) the input row indices + !! \param ja(:) the input col indices + !! \param val(:) the input coefficients + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index + !! \param info return code + !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) + !! + ! + interface + subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_base_csput_a + end interface + + interface + subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_base_csput_v + end interface + + ! + ! + !> Function csgetrow: + !! \memberof psb_lc_base_sparse_mat + !! \brief Get a (subset of) row(s) + !! + !! getrow is the basic method by which the other (getblk, clip) can + !! be implemented. + !! + !! Returns the set + !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) + !! each identifying the position of a nonzero in A + !! between row indices IMIN:IMAX; + !! IA,JA are reallocated as necessary. + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param nz the number of output coefficients + !! \param ia(:) the output row indices + !! \param ja(:) the output col indices + !! \param val(:) the output coefficients + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_lc_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_base_csgetrow + end interface + + ! + !> Function csgetblk: + !! \memberof psb_lc_base_sparse_mat + !! \brief Get a (subset of) row(s) + !! + !! getblk is very similar to getrow, except that the output + !! is packaged in a psb_lc_coo_sparse_mat object + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param b the output (sub)matrix + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_lc_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_base_csgetblk + end interface + + ! + ! + !> Function csclip: + !! \memberof psb_lc_base_sparse_mat + !! \brief Get a submatrix. + !! + !! csclip is practically identical to getblk. + !! One of them has to go away..... + !! + !! \param b the output submatrix + !! \param info return code + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_lc_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_base_csclip + end interface + ! + !> Function tril: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_lc_base_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_lc_base_tril + end interface + + ! + !> Function triu: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_lc_base_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_lc_base_triu + end interface + + + ! + !> Function get_diag: + !! \memberof psb_lc_base_sparse_mat + !! \brief Extract the diagonal of A. + !! + !! D(i) = A(i:i), i=1:min(nrows,ncols) + !! + !! \param d(:) The output diagonal + !! \param info return code. + ! + interface + subroutine psb_lc_base_get_diag(a,d,info) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_get_diag + end interface + + ! + !> Function mold: + !! \memberof psb_lc_base_sparse_mat + !! \brief Allocate a class(psb_lc_base_sparse_mat) with the + !! same dynamic type as the input. + !! This is equivalent to allocate( mold= ) and is provided + !! for those compilers not yet supporting mold. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mold(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mold + end interface + + ! + ! + !> Function clone: + !! \memberof psb_lc_base_sparse_mat + !! \brief Allocate and clone a class(psb_lc_base_sparse_mat) with the + !! same dynamic type as the input. + !! This is equivalent to allocate( source= ) except that + !! it should guarantee a deep copy wherever needed. + !! Should also be equivalent to calling mold and then copy, + !! but it can also be implemented by default using cp_to_fmt. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_clone(a,b, info) + import + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_clone + end interface + + + ! + ! + !> Function make_nonunit: + !! \memberof psb_lc_base_make_nonunit + !! \brief Given a matrix for which is_unit() is true, explicitly + !! store the unit diagonal and set is_unit() to false. + !! This is needed e.g. when scaling + ! + interface + subroutine psb_lc_base_make_nonunit(a) + import + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + end subroutine psb_lc_base_make_nonunit + end interface + + + ! + !> Function cp_to_coo: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy and convert to psb_lc_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_cp_to_coo(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_cp_to_coo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy and convert from psb_lc_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_lc_base_cp_from_coo(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_cp_from_coo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy and convert to a class(psb_lc_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_cp_to_fmt(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_cp_to_fmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy and convert from a class(psb_lc_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_cp_from_fmt(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_cp_from_fmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_lc_base_sparse_mat + !! \brief Convert to psb_lc_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mv_to_coo(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mv_to_coo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_lc_base_sparse_mat + !! \brief Convert from psb_lc_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mv_from_coo(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mv_from_coo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_lc_base_sparse_mat + !! \brief Convert to a class(psb_lc_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mv_to_fmt(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mv_to_fmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_lc_base_sparse_mat + !! \brief Convert from a class(psb_lc_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mv_from_fmt(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mv_from_fmt + end interface + + + ! + !> Function cp_to_coo: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy and convert to psb_lc_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_cp_to_icoo(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_cp_to_icoo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy and convert from psb_lc_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_lc_base_cp_from_icoo(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_cp_from_icoo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy and convert to a class(psb_lc_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_cp_to_ifmt(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_cp_to_ifmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_lc_base_sparse_mat + !! \brief Copy and convert from a class(psb_lc_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_cp_from_ifmt(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_cp_from_ifmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_lc_base_sparse_mat + !! \brief Convert to psb_lc_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mv_to_icoo(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mv_to_icoo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_lc_base_sparse_mat + !! \brief Convert from psb_lc_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mv_from_icoo(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mv_from_icoo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_lc_base_sparse_mat + !! \brief Convert to a class(psb_lc_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mv_to_ifmt(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mv_to_ifmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_lc_base_sparse_mat + !! \brief Convert from a class(psb_lc_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lc_base_mv_from_ifmt(a,b,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_mv_from_ifmt + end interface + + + + ! + !> + !! \memberof psb_lc_base_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_clean_zeros + ! + interface + subroutine psb_lc_base_clean_zeros(a, info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_clean_zeros + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_maxval + interface + function psb_lc_coo_maxval(a) result(res) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_coo_maxval + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_csnmi + interface + function psb_lc_coo_csnmi(a) result(res) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_coo_csnmi + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_csnm1 + interface + function psb_lc_coo_csnm1(a) result(res) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_coo_csnm1 + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_rowsum + interface + subroutine psb_lc_coo_rowsum(d,a) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_coo_rowsum + end interface + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_arwsum + interface + subroutine psb_lc_coo_arwsum(d,a) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_coo_arwsum + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_colsum + interface + subroutine psb_lc_coo_colsum(d,a) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_coo_colsum + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_aclsum + interface + subroutine psb_lc_coo_aclsum(d,a) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_coo_aclsum + end interface + + ! + !> Function base_scals: + !! \memberof psb_lc_base_sparse_mat + !! \brief Scale a matrix by a single scalar value + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_lc_base_scals(d,a,info) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_base_scals + end interface + + ! + !> Function base_scal: + !! \memberof psb_lc_base_sparse_mat + !! \brief Scale a matrix by a vector + !! + !! \param d(:) Scaling vector + !! \param info return code + !! \param side [L] Scale on the Left (rows) or on the Right (columns) + ! + interface + subroutine psb_lc_base_scal(d,a,info,side) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lc_base_scal + end interface + + ! + !> Function base_maxval: + !! \memberof psb_lc_base_sparse_mat + !! \brief Maximum absolute value of all coefficients; + !! + ! + interface + function psb_lc_base_maxval(a) result(res) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_base_maxval + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_lc_base_sparse_mat + !! \brief Operator infinity norm + !! + ! + interface + function psb_lc_base_csnmi(a) result(res) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_base_csnmi + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_lc_base_sparse_mat + !! \brief Operator 1-norm + !! + ! + interface + function psb_lc_base_csnm1(a) result(res) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_base_csnm1 + end interface + + ! + ! + !> Function base_rowsum: + !! \memberof psb_lc_base_sparse_mat + !! \brief Sum along the rows + !! \param d(:) The output row sums + !! + ! + interface + subroutine psb_lc_base_rowsum(d,a) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_base_rowsum + end interface + + ! + !> Function base_arwsum: + !! \memberof psb_lc_base_sparse_mat + !! \brief Absolute value sum along the rows + !! \param d(:) The output row sums + !! + interface + subroutine psb_lc_base_arwsum(d,a) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_base_arwsum + end interface + + ! + ! + !> Function base_colsum: + !! \memberof psb_lc_base_sparse_mat + !! \brief Sum along the columns + !! \param d(:) The output col sums + !! + ! + interface + subroutine psb_lc_base_colsum(d,a) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_base_colsum + end interface + + ! + !> Function base_aclsum: + !! \memberof psb_lc_base_sparse_mat + !! \brief Absolute value sum along the columns + !! \param d(:) The output col sums + !! + interface + subroutine psb_lc_base_aclsum(d,a) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_base_aclsum + end interface + + + ! + !> Function transp: + !! \memberof psb_lc_base_sparse_mat + !! \brief Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! Copyout version + !! \param b The output variable + ! + interface + subroutine psb_lc_base_transp_2mat(a,b) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + end subroutine psb_lc_base_transp_2mat + end interface + + ! + !> Function transc: + !! \memberof psb_lc_base_sparse_mat + !! \brief Conjugate Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! Copyout version. + !! \param b The output variable + ! + interface + subroutine psb_lc_base_transc_2mat(a,b) + import + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + end subroutine psb_lc_base_transc_2mat + end interface + + ! + !> Function transp: + !! \memberof psb_lc_base_sparse_mat + !! \brief Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! In-place version. + ! + interface + subroutine psb_lc_base_transp_1mat(a) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + end subroutine psb_lc_base_transp_1mat + end interface + + ! + !> Function transc: + !! \memberof psb_lc_base_sparse_mat + !! \brief Conjugate Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! In-place version. + ! + interface + subroutine psb_lc_base_transc_1mat(a) + import + class(psb_lc_base_sparse_mat), intent(inout) :: a + end subroutine psb_lc_base_transc_1mat + end interface + + ! == =============== + ! + ! COO interfaces + ! + ! == =============== + + ! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reallocate_nz + ! + interface + subroutine psb_lc_coo_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_coo_sparse_mat), intent(inout) :: a + end subroutine psb_lc_coo_reallocate_nz + end interface + + ! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reinit + ! + interface + subroutine psb_lc_coo_reinit(a,clear) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lc_coo_reinit + end interface + ! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_trim + ! + interface + subroutine psb_lc_coo_trim(a) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + end subroutine psb_lc_coo_trim + end interface + ! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_clean_zeros + ! + interface + subroutine psb_lc_coo_clean_zeros(a,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_coo_clean_zeros + end interface + + ! + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_allocate_mnnz + ! + interface + subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lc_coo_allocate_mnnz + end interface + + + !> \memberof psb_lc_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_lc_coo_mold(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_coo_mold + end interface + + + ! + !> Function print. + !! \memberof psb_lc_coo_sparse_mat + !! \brief Print the matrix to file in MatrixMarket format + !! + !! \param iout The unit to write to + !! \param iv [none] Renumbering for both rows and columns + !! \param head [none] Descriptive header for the file + !! \param ivr [none] Row renumbering + !! \param ivc [none] Col renumbering + !! + ! + interface + subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_coo_print + end interface + + + + ! + !> Function get_nz_row. + !! \memberof psb_lc_coo_sparse_mat + !! \brief How many nonzeros in a row? + !! + !! \param idx The row to search. + !! + ! + interface + function psb_lc_coo_get_nz_row(idx,a) result(res) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + end function psb_lc_coo_get_nz_row + end interface + + + ! + !> Funtion: fix_coo_inner + !! \brief Make sure the entries are sorted and duplicates are handled. + !! Used internally by fix_coo + !! \param nzin Number of entries on input to be handled + !! \param dupl What to do with duplicated entries. + !! \param ia(:) Row indices + !! \param ja(:) Col indices + !! \param val(:) Coefficients + !! \param nzout Number of entries after sorting/duplicate handling + !! \param info return code + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! + ! + interface + subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import + integer(psb_lpk_), intent(in) :: nr,nc,nzin + integer(psb_ipk_), intent(in) :: dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + complex(psb_spk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + end subroutine psb_lc_fix_coo_inner + end interface + + ! + !> Function fix_coo + !! \memberof psb_lc_coo_sparse_mat + !! \brief Make sure the entries are sorted and duplicates are handled. + !! \param info return code + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! + ! + interface + subroutine psb_lc_fix_coo(a,info,idir) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + end subroutine psb_lc_fix_coo + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo + interface + subroutine psb_lc_cp_coo_to_coo(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_coo_to_coo + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo + interface + subroutine psb_lc_cp_coo_from_coo(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_coo_from_coo + end interface + + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo + interface + subroutine psb_lc_cp_coo_to_icoo(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_coo_to_icoo + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo + interface + subroutine psb_lc_cp_coo_from_icoo(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_coo_from_icoo + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo + !! + interface + subroutine psb_lc_cp_coo_to_fmt(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_coo_to_fmt + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_fmt + !! + interface + subroutine psb_lc_cp_coo_from_fmt(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_coo_from_fmt + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_coo + interface + subroutine psb_lc_mv_coo_to_coo(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_coo_to_coo + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_coo + interface + subroutine psb_lc_mv_coo_from_coo(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_coo_from_coo + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_fmt + interface + subroutine psb_lc_mv_coo_to_fmt(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_coo_to_fmt + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_fmt + interface + subroutine psb_lc_mv_coo_from_fmt(a,b,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_coo_from_fmt + end interface + + interface + subroutine psb_lc_coo_cp_from(a,b) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + type(psb_lc_coo_sparse_mat), intent(in) :: b + end subroutine psb_lc_coo_cp_from + end interface + + interface + subroutine psb_lc_coo_mv_from(a,b) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + type(psb_lc_coo_sparse_mat), intent(inout) :: b + end subroutine psb_lc_coo_mv_from + end interface + + + !> Function csput + !! \memberof psb_lc_coo_sparse_mat + !! \brief Add coefficients into the matrix. + !! + !! \param nz Number of entries to be added + !! \param ia(:) Row indices + !! \param ja(:) Col indices + !! \param val(:) Values + !! \param imin Minimum row index to accept + !! \param imax Maximum row index to accept + !! \param jmin Minimum col index to accept + !! \param jmax Maximum col index to accept + !! \param info return code + !! \param gtl [none] Renumbering for rows/columns + !! + ! + interface + subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_coo_csput_a + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_coo_csgetptn + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csgetrow + interface + subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_coo_csgetrow + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_get_diag + interface + subroutine psb_lc_coo_get_diag(a,d,info) + import + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_coo_get_diag + end interface + + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scal + interface + subroutine psb_lc_coo_scal(d,a,info,side) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lc_coo_scal + end interface + + !> + !! \memberof psb_lc_coo_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scals + interface + subroutine psb_lc_coo_scals(d,a,info) + import + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_coo_scals + end interface contains @@ -1752,11 +3453,11 @@ contains function c_coo_sizeof(a) result(res) implicit none class(psb_c_coo_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + 1 + integer(psb_epk_) :: res + res = 3*psb_sizeof_ip res = res + (2*psb_sizeof_sp) * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%ia) - res = res + psb_sizeof_int * psb_size(a%ja) + res = res + psb_sizeof_ip * psb_size(a%ia) + res = res + psb_sizeof_ip * psb_size(a%ja) end function c_coo_sizeof @@ -1902,9 +3603,9 @@ contains if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) - call a%set_nzeros(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) + call a%set_nzeros(0_psb_ipk_) call a%set_sort_status(psb_unsorted_) return @@ -1958,6 +3659,230 @@ contains end subroutine c_coo_transc_1mat + + ! == ================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == ================================== + + + + function lc_coo_sizeof(a) result(res) + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 3*psb_sizeof_lp + res = res + (2*psb_sizeof_sp) * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%ia) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function lc_coo_sizeof + + + function lc_coo_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'COO' + end function lc_coo_get_fmt + + + function lc_coo_get_size(a) result(res) + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = -1 + + if (allocated(a%ia)) res = size(a%ia) + if (allocated(a%ja)) then + if (res >= 0) then + res = min(res,size(a%ja)) + else + res = size(a%ja) + end if + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + end function lc_coo_get_size + + + function lc_coo_get_nzeros(a) result(res) + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%nnz + end function lc_coo_get_nzeros + + function lc_coo_is_by_rows(a) result(res) + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_row_major_) + end function lc_coo_is_by_rows + + function lc_coo_is_by_cols(a) result(res) + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_col_major_) + end function lc_coo_is_by_cols + + function lc_coo_is_sorted(a) result(res) + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_row_major_) & + & .or.(a%sort_status == psb_col_major_) + end function lc_coo_is_sorted + + + + ! == ================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == ================================== + + subroutine lc_coo_set_nzeros(nz,a) + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_coo_sparse_mat), intent(inout) :: a + + a%nnz = nz + + end subroutine lc_coo_set_nzeros + + function lc_coo_get_sort_status(a) result(res) + implicit none + integer(psb_ipk_) :: res + class(psb_lc_coo_sparse_mat), intent(in) :: a + + res = a%sort_status + end function lc_coo_get_sort_status + + subroutine lc_coo_set_sort_status(ist,a) + implicit none + integer(psb_ipk_), intent(in) :: ist + class(psb_lc_coo_sparse_mat), intent(inout) :: a + + a%sort_status = ist + call a%set_sorted((a%sort_status == psb_row_major_) & + & .or.(a%sort_status == psb_col_major_)) + end subroutine lc_coo_set_sort_status + + + subroutine lc_coo_set_by_rows(a) + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + + a%sort_status = psb_row_major_ + call a%set_sorted() + end subroutine lc_coo_set_by_rows + + + subroutine lc_coo_set_by_cols(a) + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + + a%sort_status = psb_col_major_ + call a%set_sorted() + end subroutine lc_coo_set_by_cols + + ! == ================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == ================================== + + subroutine lc_coo_free(a) + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + call a%set_nzeros(0_psb_lpk_) + call a%set_sort_status(psb_unsorted_) + + return + + end subroutine lc_coo_free + + + + ! == ================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + ! == ================================== + subroutine lc_coo_transp_1mat(a) + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + + integer(psb_lpk_), allocatable :: itemp(:) + integer(psb_ipk_) :: info + + call a%psb_lc_base_sparse_mat%psb_lbase_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%set_sorted(.false.) + call a%set_sort_status(psb_unsorted_) + + return + + end subroutine lc_coo_transp_1mat + + subroutine lc_coo_transc_1mat(a) + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + + call a%transp() + ! This will morph into conjg() for C and Z + ! and into a no-op for S and D, so a conditional + ! on a constant ought to take it out completely. + if (psb_lc_is_complex_) a%val(:) = conjg(a%val(:)) + + end subroutine lc_coo_transc_1mat + end module psb_c_base_mat_mod diff --git a/base/modules/serial/psb_c_base_vect_mod.f90 b/base/modules/serial/psb_c_base_vect_mod.f90 index ec9d1d995..59f9816d3 100644 --- a/base/modules/serial/psb_c_base_vect_mod.f90 +++ b/base/modules/serial/psb_c_base_vect_mod.f90 @@ -48,6 +48,7 @@ module psb_c_base_vect_mod use psb_error_mod use psb_realloc_mod use psb_i_base_vect_mod + use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_c_base_vect_type !! The psb_c_base_vect_type @@ -63,14 +64,15 @@ module psb_c_base_vect_mod !> Values. complex(psb_spk_), allocatable :: v(:) complex(psb_spk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators ! procedure, pass(x) :: bld_x => c_base_bld_x - procedure, pass(x) :: bld_n => c_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => c_base_bld_mn + procedure, pass(x) :: bld_en => c_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => c_base_all procedure, pass(x) :: mold => c_base_mold ! @@ -82,7 +84,9 @@ module psb_c_base_vect_mod procedure, pass(x) :: ins_v => c_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => c_base_zero - procedure, pass(x) :: asb => c_base_asb + procedure, pass(x) :: asb_m => c_base_asb_m + procedure, pass(x) :: asb_e => c_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => c_base_free ! ! Sync: centerpiece of handling of external storage. @@ -240,22 +244,39 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_c_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine c_base_bld_n(x,n) + subroutine c_base_bld_mn(x,n) use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine c_base_bld_n + end subroutine c_base_bld_mn + + !> Function bld_en: + !! \memberof psb_c_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine c_base_bld_en(x,n) + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine c_base_bld_en !> Function base_all: !! \memberof psb_c_base_vect_type @@ -437,11 +458,11 @@ contains !! ! - subroutine c_base_asb(n, x, info) + subroutine c_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -451,7 +472,37 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine c_base_asb + end subroutine c_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_c_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine c_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine c_base_asb_e ! !> Function base_free: @@ -662,10 +713,10 @@ contains function c_base_sizeof(x) result(res) implicit none class(psb_c_base_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * (2*psb_sizeof_sp)) * x%get_nrows() + res = (1_psb_epk_ * (2*psb_sizeof_sp)) * x%get_nrows() end function c_base_sizeof @@ -753,7 +804,6 @@ contains integer(psb_ipk_) :: info, first_, last_, nr - first_ = 1 if (present(first)) first_ = max(1,first) last_ = min(psb_size(x%v),first_+size(val)-1) @@ -1415,7 +1465,7 @@ module psb_c_base_multivect_mod !> Values. complex(psb_spk_), allocatable :: v(:,:) complex(psb_spk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1933,10 +1983,10 @@ contains function c_base_mlv_sizeof(x) result(res) implicit none class(psb_c_base_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() end function c_base_mlv_sizeof diff --git a/base/modules/serial/psb_c_csc_mat_mod.f90 b/base/modules/serial/psb_c_csc_mat_mod.f90 index 2bb7982cf..d5718de7a 100644 --- a/base/modules/serial/psb_c_csc_mat_mod.f90 +++ b/base/modules/serial/psb_c_csc_mat_mod.f90 @@ -100,14 +100,69 @@ module psb_c_csc_mat_mod end type psb_c_csc_sparse_mat - private :: c_csc_get_nzeros, c_csc_free, c_csc_get_fmt, & + private :: c_csc_get_nzeros, c_csc_free, c_csc_get_fmt, & & c_csc_get_size, c_csc_sizeof, c_csc_get_nz_col + + !> \namespace psb_base_mod \class psb_c_csc_sparse_mat + !! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat + !! + !! psb_c_csc_sparse_mat type and the related methods. + !! + type, extends(psb_lc_base_sparse_mat) :: psb_lc_csc_sparse_mat + + !> Pointers to beginning of cols in IA and VAL. + integer(psb_lpk_), allocatable :: icp(:) + !> Row indices. + integer(psb_lpk_), allocatable :: ia(:) + !> Coefficient values. + complex(psb_spk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_cols => lc_csc_is_by_cols + procedure, pass(a) :: get_size => lc_csc_get_size + procedure, pass(a) :: get_nzeros => lc_csc_get_nzeros + procedure, nopass :: get_fmt => lc_csc_get_fmt + procedure, pass(a) :: sizeof => lc_csc_sizeof + procedure, pass(a) :: scals => psb_lc_csc_scals + procedure, pass(a) :: scalv => psb_lc_csc_scal + procedure, pass(a) :: maxval => psb_lc_csc_maxval + procedure, pass(a) :: spnm1 => psb_lc_csc_csnm1 + procedure, pass(a) :: rowsum => psb_lc_csc_rowsum + procedure, pass(a) :: arwsum => psb_lc_csc_arwsum + procedure, pass(a) :: colsum => psb_lc_csc_colsum + procedure, pass(a) :: aclsum => psb_lc_csc_aclsum + procedure, pass(a) :: reallocate_nz => psb_lc_csc_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_lc_csc_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_lc_cp_csc_to_coo + procedure, pass(a) :: cp_from_coo => psb_lc_cp_csc_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lc_cp_csc_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lc_cp_csc_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lc_mv_csc_to_coo + procedure, pass(a) :: mv_from_coo => psb_lc_mv_csc_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lc_mv_csc_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lc_mv_csc_from_fmt + procedure, pass(a) :: csput_a => psb_lc_csc_csput_a + procedure, pass(a) :: get_diag => psb_lc_csc_get_diag + procedure, pass(a) :: csgetptn => psb_lc_csc_csgetptn + procedure, pass(a) :: csgetrow => psb_lc_csc_csgetrow + procedure, pass(a) :: get_nz_col => lc_csc_get_nz_col + procedure, pass(a) :: reinit => psb_lc_csc_reinit + procedure, pass(a) :: trim => psb_lc_csc_trim + procedure, pass(a) :: print => psb_lc_csc_print + procedure, pass(a) :: free => lc_csc_free + procedure, pass(a) :: mold => psb_lc_csc_mold + + end type psb_lc_csc_sparse_mat + + private :: lc_csc_get_nzeros, lc_csc_free, lc_csc_get_fmt, & + & lc_csc_get_size, lc_csc_sizeof, lc_csc_get_nz_col + !> \memberof psb_c_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface subroutine psb_c_csc_reallocate_nz(nz,a) - import :: psb_ipk_, psb_c_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_c_csc_sparse_mat), intent(inout) :: a end subroutine psb_c_csc_reallocate_nz @@ -117,7 +172,7 @@ module psb_c_csc_mat_mod !| \see psb_base_mat_mod::psb_base_reinit interface subroutine psb_c_csc_reinit(a,clear) - import :: psb_ipk_, psb_c_csc_sparse_mat + import class(psb_c_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_c_csc_reinit @@ -127,7 +182,7 @@ module psb_c_csc_mat_mod !| \see psb_base_mat_mod::psb_base_trim interface subroutine psb_c_csc_trim(a) - import :: psb_ipk_, psb_c_csc_sparse_mat + import class(psb_c_csc_sparse_mat), intent(inout) :: a end subroutine psb_c_csc_trim end interface @@ -136,7 +191,7 @@ module psb_c_csc_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_c_csc_mold(a,b,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ + import class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -147,7 +202,7 @@ module psb_c_csc_mat_mod !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface subroutine psb_c_csc_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_c_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_c_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -159,7 +214,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_print interface subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_c_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -172,7 +227,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_to_coo interface subroutine psb_c_cp_csc_to_coo(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_csc_sparse_mat + import class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -183,7 +238,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo interface subroutine psb_c_cp_csc_from_coo(a,b,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_coo_sparse_mat + import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -194,7 +249,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_to_fmt interface subroutine psb_c_cp_csc_to_fmt(a,b,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -205,7 +260,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_from_fmt interface subroutine psb_c_cp_csc_from_fmt(a,b,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -216,7 +271,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_to_coo interface subroutine psb_c_mv_csc_to_coo(a,b,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_coo_sparse_mat + import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -227,7 +282,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_from_coo interface subroutine psb_c_mv_csc_from_coo(a,b,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_coo_sparse_mat + import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -238,7 +293,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_to_fmt interface subroutine psb_c_mv_csc_to_fmt(a,b,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -249,7 +304,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_from_fmt interface subroutine psb_c_mv_csc_from_fmt(a,b,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_csc_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -260,7 +315,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_from interface subroutine psb_c_csc_cp_from(a,b) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(inout) :: a type(psb_c_csc_sparse_mat), intent(in) :: b end subroutine psb_c_csc_cp_from @@ -270,7 +325,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_from interface subroutine psb_c_csc_mv_from(a,b) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(inout) :: a type(psb_c_csc_sparse_mat), intent(inout) :: b end subroutine psb_c_csc_mv_from @@ -281,7 +336,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csput_a interface subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -296,7 +351,7 @@ module psb_c_csc_mat_mod interface subroutine psb_c_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -328,28 +383,28 @@ module psb_c_csc_mat_mod end subroutine psb_c_csc_csgetrow end interface -!!$ !> \memberof psb_c_csc_sparse_mat -!!$ !! \see psb_c_base_mat_mod::psb_c_base_csgetblk -!!$ interface -!!$ subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& -!!$ & jmin,jmax,iren,append,rscale,cscale,chksz) -!!$ import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_, psb_c_coo_sparse_mat -!!$ class(psb_c_csc_sparse_mat), intent(in) :: a -!!$ class(psb_c_coo_sparse_mat), intent(inout) :: b -!!$ integer(psb_ipk_), intent(in) :: imin,imax -!!$ integer(psb_ipk_),intent(out) :: info -!!$ logical, intent(in), optional :: append -!!$ integer(psb_ipk_), intent(in), optional :: iren(:) -!!$ integer(psb_ipk_), intent(in), optional :: jmin,jmax -!!$ logical, intent(in), optional :: rscale,cscale,chksz -!!$ end subroutine psb_c_csc_csgetblk -!!$ end interface -!!$ + !> \memberof psb_c_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_c_base_csgetblk + interface + subroutine psb_c_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale,chksz) + import + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale,chksz + end subroutine psb_c_csc_csgetblk + end interface + !> \memberof psb_c_csc_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cssv interface subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -361,7 +416,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cssm interface subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -374,7 +429,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csmv interface subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -387,7 +442,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csmm interface subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -401,7 +456,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_maxval interface function psb_c_csc_maxval(a) result(res) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_csc_maxval @@ -411,7 +466,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csnm1 interface function psb_c_csc_csnm1(a) result(res) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_csc_csnm1 @@ -421,7 +476,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_rowsum interface subroutine psb_c_csc_rowsum(d,a) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csc_rowsum @@ -431,7 +486,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_arwsum interface subroutine psb_c_csc_arwsum(d,a) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csc_arwsum @@ -441,7 +496,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_colsum interface subroutine psb_c_csc_colsum(d,a) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csc_colsum @@ -451,7 +506,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_aclsum interface subroutine psb_c_csc_aclsum(d,a) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csc_aclsum @@ -461,7 +516,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_get_diag interface subroutine psb_c_csc_get_diag(a,d,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -472,7 +527,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_scal interface subroutine psb_c_csc_scal(d,a,info,side) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -484,7 +539,7 @@ module psb_c_csc_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_scals interface subroutine psb_c_csc_scals(d,a,info) - import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_ + import class(psb_c_csc_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -492,6 +547,347 @@ module psb_c_csc_mat_mod end interface + ! + ! lc + ! + !> \memberof psb_lc_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_lc_csc_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_csc_sparse_mat), intent(inout) :: a + end subroutine psb_lc_csc_reallocate_nz + end interface + + !> \memberof psb_lc_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_lc_csc_reinit(a,clear) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lc_csc_reinit + end interface + + !> \memberof psb_lc_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_lc_csc_trim(a) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + end subroutine psb_lc_csc_trim + end interface + + !> \memberof psb_lc_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_lc_csc_mold(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csc_mold + end interface + + !> \memberof psb_lc_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_lc_csc_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lc_csc_allocate_mnnz + end interface + + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_print + interface + subroutine psb_lc_csc_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_csc_print + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo + interface + subroutine psb_lc_cp_csc_to_coo(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csc_to_coo + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo + interface + subroutine psb_lc_cp_csc_from_coo(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csc_from_coo + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_fmt + interface + subroutine psb_lc_cp_csc_to_fmt(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csc_to_fmt + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_fmt + interface + subroutine psb_lc_cp_csc_from_fmt(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csc_from_fmt + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_coo + interface + subroutine psb_lc_mv_csc_to_coo(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csc_to_coo + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_coo + interface + subroutine psb_lc_mv_csc_from_coo(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csc_from_coo + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_fmt + interface + subroutine psb_lc_mv_csc_to_fmt(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csc_to_fmt + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_fmt + interface + subroutine psb_lc_mv_csc_from_fmt(a,b,info) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csc_from_fmt + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from + interface + subroutine psb_lc_csc_cp_from(a,b) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + type(psb_lc_csc_sparse_mat), intent(in) :: b + end subroutine psb_lc_csc_cp_from + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from + interface + subroutine psb_lc_csc_mv_from(a,b) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + type(psb_lc_csc_sparse_mat), intent(inout) :: b + end subroutine psb_lc_csc_mv_from + end interface + + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csput_a + interface + subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_csc_csput_a + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_lc_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csc_csgetptn + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csgetrow + interface + subroutine psb_lc_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csc_csgetrow + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csgetblk + interface + subroutine psb_lc_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csc_csgetblk + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_get_diag + interface + subroutine psb_lc_csc_get_diag(a,d,info) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csc_get_diag + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_maxval + interface + function psb_lc_csc_maxval(a) result(res) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csc_maxval + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_csnm1 + interface + function psb_lc_csc_csnm1(a) result(res) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csc_csnm1 + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_rowsum + interface + subroutine psb_lc_csc_rowsum(d,a) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csc_rowsum + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_arwsum + interface + subroutine psb_lc_csc_arwsum(d,a) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csc_arwsum + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_colsum + interface + subroutine psb_lc_csc_colsum(d,a) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csc_colsum + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_aclsum + interface + subroutine psb_lc_csc_aclsum(d,a) + import + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csc_aclsum + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scal + interface + subroutine psb_lc_csc_scal(d,a,info,side) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lc_csc_scal + end interface + + !> \memberof psb_lc_csc_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scals + interface + subroutine psb_lc_csc_scals(d,a,info) + import + class(psb_lc_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csc_scals + end interface + + + contains ! == =================================== @@ -519,11 +915,11 @@ contains function c_csc_sizeof(a) result(res) implicit none class(psb_c_csc_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + integer(psb_epk_) :: res + res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_sp) * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%icp) - res = res + psb_sizeof_int * psb_size(a%ia) + res = res + psb_sizeof_ip * psb_size(a%icp) + res = res + psb_sizeof_ip * psb_size(a%ia) end function c_csc_sizeof @@ -602,11 +998,133 @@ contains if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) return end subroutine c_csc_free + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function lc_csc_is_by_cols(a) result(res) + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function lc_csc_is_by_cols + + ! + ! lc + ! + + function lc_csc_sizeof(a) result(res) + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2*psb_sizeof_lp + res = res + (2*psb_sizeof_sp) * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%icp) + res = res + psb_sizeof_lp * psb_size(a%ia) + + end function lc_csc_sizeof + + function lc_csc_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSC' + end function lc_csc_get_fmt + + function lc_csc_get_nzeros(a) result(res) + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%icp(a%get_ncols()+1)-1 + end function lc_csc_get_nzeros + + function lc_csc_get_size(a) result(res) + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ia)) then + res = size(a%ia) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function lc_csc_get_size + + + + function lc_csc_get_nz_col(idx,a) result(res) + use psb_const_mod + implicit none + + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then + res = a%icp(idx+1)-a%icp(idx) + end if + + end function lc_csc_get_nz_col + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + + subroutine lc_csc_free(a) + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + + if (allocated(a%icp)) deallocate(a%icp) + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine lc_csc_free + + + end module psb_c_csc_mat_mod diff --git a/base/modules/serial/psb_c_csr_mat_mod.f90 b/base/modules/serial/psb_c_csr_mat_mod.f90 index af4f3165c..43b0c224d 100644 --- a/base/modules/serial/psb_c_csr_mat_mod.f90 +++ b/base/modules/serial/psb_c_csr_mat_mod.f90 @@ -111,7 +111,7 @@ module psb_c_csr_mat_mod !| \see psb_base_mat_mod::psb_base_reallocate_nz interface subroutine psb_c_csr_reallocate_nz(nz,a) - import :: psb_ipk_, psb_c_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_c_csr_sparse_mat), intent(inout) :: a end subroutine psb_c_csr_reallocate_nz @@ -121,7 +121,7 @@ module psb_c_csr_mat_mod !| \see psb_base_mat_mod::psb_base_reinit interface subroutine psb_c_csr_reinit(a,clear) - import :: psb_ipk_, psb_c_csr_sparse_mat + import class(psb_c_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_c_csr_reinit @@ -131,7 +131,7 @@ module psb_c_csr_mat_mod !| \see psb_base_mat_mod::psb_base_trim interface subroutine psb_c_csr_trim(a) - import :: psb_ipk_, psb_c_csr_sparse_mat + import class(psb_c_csr_sparse_mat), intent(inout) :: a end subroutine psb_c_csr_trim end interface @@ -141,7 +141,7 @@ module psb_c_csr_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_c_csr_mold(a,b,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ + import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -152,7 +152,7 @@ module psb_c_csr_mat_mod !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_c_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_c_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -164,7 +164,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_print interface subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_c_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -205,7 +205,7 @@ module psb_c_csr_mat_mod interface subroutine psb_c_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -249,7 +249,7 @@ module psb_c_csr_mat_mod interface subroutine psb_c_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_coo_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -264,7 +264,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_to_coo interface subroutine psb_c_cp_csr_to_coo(a,b,info) - import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_csr_sparse_mat + import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -275,7 +275,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_from_coo interface subroutine psb_c_cp_csr_from_coo(a,b,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_coo_sparse_mat + import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -286,7 +286,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_to_fmt interface subroutine psb_c_cp_csr_to_fmt(a,b,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -297,7 +297,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_from_fmt interface subroutine psb_c_cp_csr_from_fmt(a,b,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -308,7 +308,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_to_coo interface subroutine psb_c_mv_csr_to_coo(a,b,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_coo_sparse_mat + import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -319,7 +319,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_from_coo interface subroutine psb_c_mv_csr_from_coo(a,b,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_coo_sparse_mat + import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -330,7 +330,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_to_fmt interface subroutine psb_c_mv_csr_to_fmt(a,b,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -341,7 +341,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_from_fmt interface subroutine psb_c_mv_csr_from_fmt(a,b,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_base_sparse_mat + import class(psb_c_csr_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -352,7 +352,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cp_from interface subroutine psb_c_csr_cp_from(a,b) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(inout) :: a type(psb_c_csr_sparse_mat), intent(in) :: b end subroutine psb_c_csr_cp_from @@ -362,7 +362,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_mv_from interface subroutine psb_c_csr_mv_from(a,b) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(inout) :: a type(psb_c_csr_sparse_mat), intent(inout) :: b end subroutine psb_c_csr_mv_from @@ -373,7 +373,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csput_a interface subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -388,7 +388,7 @@ module psb_c_csr_mat_mod interface subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -406,7 +406,7 @@ module psb_c_csr_mat_mod interface subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -419,29 +419,12 @@ module psb_c_csr_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_c_csr_csgetrow end interface -!!$ -!!$ !> \memberof psb_c_csr_sparse_mat -!!$ !! \see psb_c_base_mat_mod::psb_c_base_csgetblk -!!$ interface -!!$ subroutine psb_c_csr_csgetblk(imin,imax,a,b,info,& -!!$ & jmin,jmax,iren,append,rscale,cscale) -!!$ import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_, psb_c_coo_sparse_mat -!!$ class(psb_c_csr_sparse_mat), intent(in) :: a -!!$ class(psb_c_coo_sparse_mat), intent(inout) :: b -!!$ integer(psb_ipk_), intent(in) :: imin,imax -!!$ integer(psb_ipk_),intent(out) :: info -!!$ logical, intent(in), optional :: append -!!$ integer(psb_ipk_), intent(in), optional :: iren(:) -!!$ integer(psb_ipk_), intent(in), optional :: jmin,jmax -!!$ logical, intent(in), optional :: rscale,cscale -!!$ end subroutine psb_c_csr_csgetblk -!!$ end interface - + !> \memberof psb_c_csr_sparse_mat !! \see psb_c_base_mat_mod::psb_c_base_cssv interface subroutine psb_c_csr_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -453,7 +436,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_cssm interface subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -466,7 +449,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csmv interface subroutine psb_c_csr_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:) complex(psb_spk_), intent(inout) :: y(:) @@ -479,7 +462,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csmm interface subroutine psb_c_csr_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) @@ -493,7 +476,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_maxval interface function psb_c_csr_maxval(a) result(res) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_csr_maxval @@ -503,7 +486,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_csnmi interface function psb_c_csr_csnmi(a) result(res) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_c_csr_csnmi @@ -513,7 +496,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_rowsum interface subroutine psb_c_csr_rowsum(d,a) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csr_rowsum @@ -523,7 +506,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_arwsum interface subroutine psb_c_csr_arwsum(d,a) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csr_arwsum @@ -533,7 +516,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_colsum interface subroutine psb_c_csr_colsum(d,a) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csr_colsum @@ -543,7 +526,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_aclsum interface subroutine psb_c_csr_aclsum(d,a) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_c_csr_aclsum @@ -553,7 +536,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_get_diag interface subroutine psb_c_csr_get_diag(a,d,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -564,7 +547,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_scal interface subroutine psb_c_csr_scal(d,a,info,side) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -576,7 +559,7 @@ module psb_c_csr_mat_mod !! \see psb_c_base_mat_mod::psb_c_base_scals interface subroutine psb_c_csr_scals(d,a,info) - import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_ + import class(psb_c_csr_sparse_mat), intent(inout) :: a complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -584,6 +567,471 @@ module psb_c_csr_mat_mod end interface + !> \namespace psb_base_mod \class psb_lc_csr_sparse_mat + !! \extends psb_lc_base_mat_mod::psb_lc_base_sparse_mat + !! + !! psb_lc_csr_sparse_mat type and the related methods. + !! This is a very common storage type, and is the default for assembled + !! matrices in our library + type, extends(psb_lc_base_sparse_mat) :: psb_lc_csr_sparse_mat + + !> Pointers to beginning of rows in JA and VAL. + integer(psb_lpk_), allocatable :: irp(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + complex(psb_spk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_rows => lc_csr_is_by_rows + procedure, pass(a) :: get_size => lc_csr_get_size + procedure, pass(a) :: get_nzeros => lc_csr_get_nzeros + procedure, nopass :: get_fmt => lc_csr_get_fmt + procedure, pass(a) :: sizeof => lc_csr_sizeof + procedure, pass(a) :: reallocate_nz => psb_lc_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_lc_csr_allocate_mnnz + procedure, pass(a) :: tril => psb_lc_csr_tril + procedure, pass(a) :: triu => psb_lc_csr_triu + procedure, pass(a) :: cp_to_coo => psb_lc_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_lc_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lc_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lc_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lc_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_lc_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lc_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lc_mv_csr_from_fmt + procedure, pass(a) :: csput_a => psb_lc_csr_csput_a + procedure, pass(a) :: get_diag => psb_lc_csr_get_diag + procedure, pass(a) :: csgetptn => psb_lc_csr_csgetptn + procedure, pass(a) :: csgetrow => psb_lc_csr_csgetrow + procedure, pass(a) :: get_nz_row => lc_csr_get_nz_row + procedure, pass(a) :: reinit => psb_lc_csr_reinit + procedure, pass(a) :: trim => psb_lc_csr_trim + procedure, pass(a) :: print => psb_lc_csr_print + procedure, pass(a) :: free => lc_csr_free + procedure, pass(a) :: mold => psb_lc_csr_mold + procedure, pass(a) :: scals => psb_lc_csr_scals + procedure, pass(a) :: scalv => psb_lc_csr_scal + procedure, pass(a) :: maxval => psb_lc_csr_maxval + procedure, pass(a) :: spnmi => psb_lc_csr_csnmi + procedure, pass(a) :: rowsum => psb_lc_csr_rowsum + procedure, pass(a) :: arwsum => psb_lc_csr_arwsum + procedure, pass(a) :: colsum => psb_lc_csr_colsum + procedure, pass(a) :: aclsum => psb_lc_csr_aclsum + + end type psb_lc_csr_sparse_mat + + private :: lc_csr_get_nzeros, lc_csr_free, lc_csr_get_fmt, & + & lc_csr_get_size, lc_csr_sizeof, lc_csr_get_nz_row, & + & lc_csr_is_by_rows + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_lc_csr_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_csr_sparse_mat), intent(inout) :: a + end subroutine psb_lc_csr_reallocate_nz + end interface + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_lc_csr_reinit(a,clear) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lc_csr_reinit + end interface + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_lc_csr_trim(a) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + end subroutine psb_lc_csr_trim + end interface + + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_lc_csr_mold(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csr_mold + end interface + + !> \memberof psb_lc_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lc_csr_allocate_mnnz + end interface + + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_print + interface + subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_csr_print + end interface + ! + !> Function tril: + !! \memberof psb_c_base_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_lc_csr_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_lc_csr_tril + end interface + + ! + !> Function triu: + !! \memberof psb_c_csr_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_lc_csr_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_lc_csr_triu + end interface + + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_coo + interface + subroutine psb_lc_cp_csr_to_coo(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csr_to_coo + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_coo + interface + subroutine psb_lc_cp_csr_from_coo(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csr_from_coo + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_to_fmt + interface + subroutine psb_lc_cp_csr_to_fmt(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csr_to_fmt + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from_fmt + interface + subroutine psb_lc_cp_csr_from_fmt(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_cp_csr_from_fmt + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_coo + interface + subroutine psb_lc_mv_csr_to_coo(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csr_to_coo + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_coo + interface + subroutine psb_lc_mv_csr_from_coo(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csr_from_coo + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_to_fmt + interface + subroutine psb_lc_mv_csr_to_fmt(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csr_to_fmt + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from_fmt + interface + subroutine psb_lc_mv_csr_from_fmt(a,b,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_mv_csr_from_fmt + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_cp_from + interface + subroutine psb_lc_csr_cp_from(a,b) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + type(psb_lc_csr_sparse_mat), intent(in) :: b + end subroutine psb_lc_csr_cp_from + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_mv_from + interface + subroutine psb_lc_csr_mv_from(a,b) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + type(psb_lc_csr_sparse_mat), intent(inout) :: b + end subroutine psb_lc_csr_mv_from + end interface + + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csput_a + interface + subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_csr_csput_a + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_lc_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csr_csgetptn + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_csgetrow + interface + subroutine psb_lc_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csr_csgetrow + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_get_diag + interface + subroutine psb_lc_csr_get_diag(a,d,info) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csr_get_diag + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scal + interface + subroutine psb_lc_csr_scal(d,a,info,side) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lc_csr_scal + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_lc_base_mat_mod::psb_lc_base_scals + interface + subroutine psb_lc_csr_scals(d,a,info) + import + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_csr_scals + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_maxval + interface + function psb_lc_csr_maxval(a) result(res) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csr_maxval + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_csnmi + interface + function psb_lc_csr_csnmi(a) result(res) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csr_csnmi + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_rowsum + interface + subroutine psb_lc_csr_rowsum(d,a) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csr_rowsum + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_arwsum + interface + subroutine psb_lc_csr_arwsum(d,a) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csr_arwsum + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_colsum + interface + subroutine psb_lc_csr_colsum(d,a) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csr_colsum + end interface + + !> \memberof psb_lc_csr_sparse_mat + !! \see psb_c_base_mat_mod::psb_lc_base_aclsum + interface + subroutine psb_lc_csr_aclsum(d,a) + import + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_lc_csr_aclsum + end interface + contains @@ -613,11 +1061,11 @@ contains function c_csr_sizeof(a) result(res) implicit none class(psb_c_csr_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + integer(psb_epk_) :: res + res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_sp) * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%irp) - res = res + psb_sizeof_int * psb_size(a%ja) + res = res + psb_sizeof_ip * psb_size(a%irp) + res = res + psb_sizeof_ip * psb_size(a%ja) end function c_csr_sizeof @@ -695,12 +1143,128 @@ contains if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) return end subroutine c_csr_free + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + + function lc_csr_is_by_rows(a) result(res) + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function lc_csr_is_by_rows + + + function lc_csr_sizeof(a) result(res) + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2 * psb_sizeof_lp + res = res + (2*psb_sizeof_sp) * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function lc_csr_sizeof + + function lc_csr_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSR' + end function lc_csr_get_fmt + + function lc_csr_get_nzeros(a) result(res) + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%irp(a%get_nrows()+1)-1 + end function lc_csr_get_nzeros + + function lc_csr_get_size(a) result(res) + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ja)) then + res = size(a%ja) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function lc_csr_get_size + + + + function lc_csr_get_nz_row(idx,a) result(res) + + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function lc_csr_get_nz_row + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + subroutine lc_csr_free(a) + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine lc_csr_free + end module psb_c_csr_mat_mod diff --git a/base/modules/serial/psb_c_mat_mod.F90 b/base/modules/serial/psb_c_mat_mod.F90 new file mode 100644 index 000000000..e07eb667a --- /dev/null +++ b/base/modules/serial/psb_c_mat_mod.F90 @@ -0,0 +1,2740 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_c_mat_mod +! +! This module contains the definition of the psb_c_sparse type which +! is a generic container for a sparse matrix and it is mostly meant to +! provide a mean of switching, at run-time, among different formats, +! potentially unknown at the library compile-time by adding a layer of +! indirection. This type encapsulates the psb_c_base_sparse_mat class +! inside another class which is the one visible to the user. +! Most methods of the psb_c_mat_mod simply call the methods of the +! encapsulated class. +! The exceptions are mainly cscnv and cp_from/cp_to; these provide +! the functionalities to have the encapsulated class change its +! type dynamically, and to extract/input an inner object. +! +! A sparse matrix has a state corresponding to its progression +! through the application life. +! In particular, computational methods can only be invoked when +! the matrix is in the ASSEMBLED state, whereas the other states are +! dedicated to operations on the internal matrix data. +! A sparse matrix can move between states according to the +! following state transition table. Associated with these states are +! the possible dynamic types of the inner matrix object. +! Only COO matrices can ever be in the BUILD state, whereas +! the ASSEMBLED and UPDATE state can be entered by any class. +! +! In Out Method +!| ---------------------------------- +!| Null Build csall +!| Build Build csput +!| Build Assembled cscnv +!| Assembled Assembled cscnv +!| Assembled Update reinit +!| Update Update csput +!| Update Assembled cscnv +!| * unchanged reall +!| Assembled Null free +! +! +! +! We are also introducing the type psb_lcspmat_type. +! The basic difference with psb_cspmat_type is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! +module psb_c_mat_mod + + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat, psb_lc_csr_sparse_mat + use psb_c_csc_mat_mod, only : psb_c_csc_sparse_mat, psb_lc_csc_sparse_mat + + type :: psb_cspmat_type + + class(psb_c_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_c_get_nrows + procedure, pass(a) :: get_ncols => psb_c_get_ncols + procedure, pass(a) :: get_nzeros => psb_c_get_nzeros + procedure, pass(a) :: get_nz_row => psb_c_get_nz_row + procedure, pass(a) :: get_size => psb_c_get_size + procedure, pass(a) :: get_dupl => psb_c_get_dupl + procedure, pass(a) :: is_null => psb_c_is_null + procedure, pass(a) :: is_bld => psb_c_is_bld + procedure, pass(a) :: is_upd => psb_c_is_upd + procedure, pass(a) :: is_asb => psb_c_is_asb + procedure, pass(a) :: is_sorted => psb_c_is_sorted + procedure, pass(a) :: is_by_rows => psb_c_is_by_rows + procedure, pass(a) :: is_by_cols => psb_c_is_by_cols + procedure, pass(a) :: is_upper => psb_c_is_upper + procedure, pass(a) :: is_lower => psb_c_is_lower + procedure, pass(a) :: is_triangle => psb_c_is_triangle + procedure, pass(a) :: is_unit => psb_c_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_c_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_c_get_fmt + procedure, pass(a) :: sizeof => psb_c_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_c_set_nrows + procedure, pass(a) :: set_ncols => psb_c_set_ncols + procedure, pass(a) :: set_dupl => psb_c_set_dupl + procedure, pass(a) :: set_null => psb_c_set_null + procedure, pass(a) :: set_bld => psb_c_set_bld + procedure, pass(a) :: set_upd => psb_c_set_upd + procedure, pass(a) :: set_asb => psb_c_set_asb + procedure, pass(a) :: set_sorted => psb_c_set_sorted + procedure, pass(a) :: set_upper => psb_c_set_upper + procedure, pass(a) :: set_lower => psb_c_set_lower + procedure, pass(a) :: set_triangle => psb_c_set_triangle + procedure, pass(a) :: set_unit => psb_c_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_c_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_c_csall + procedure, pass(a) :: free => psb_c_free + procedure, pass(a) :: trim => psb_c_trim + procedure, pass(a) :: csput_a => psb_c_csput_a + procedure, pass(a) :: csput_v => psb_c_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_c_csgetptn + procedure, pass(a) :: csgetrow => psb_c_csgetrow + procedure, pass(a) :: csgetblk => psb_c_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: lcsgetptn => psb_c_lcsgetptn + procedure, pass(a) :: lcsgetrow => psb_c_lcsgetrow + generic, public :: csget => lcsgetptn, lcsgetrow +#endif + procedure, pass(a) :: tril => psb_c_tril + procedure, pass(a) :: triu => psb_c_triu + procedure, pass(a) :: m_csclip => psb_c_csclip + procedure, pass(a) :: b_csclip => psb_c_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_c_clean_zeros + procedure, pass(a) :: reall => psb_c_reallocate_nz + procedure, pass(a) :: get_neigh => psb_c_get_neigh + procedure, pass(a) :: reinit => psb_c_reinit + procedure, pass(a) :: print_i => psb_c_sparse_print + procedure, pass(a) :: print_n => psb_c_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_c_mold + procedure, pass(a) :: asb => psb_c_asb + procedure, pass(a) :: transp_1mat => psb_c_transp_1mat + procedure, pass(a) :: transp_2mat => psb_c_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_c_transc_1mat + procedure, pass(a) :: transc_2mat => psb_c_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => c_mat_sync + procedure, pass(a) :: is_host => c_mat_is_host + procedure, pass(a) :: is_dev => c_mat_is_dev + procedure, pass(a) :: is_sync => c_mat_is_sync + procedure, pass(a) :: set_host => c_mat_set_host + procedure, pass(a) :: set_dev => c_mat_set_dev + procedure, pass(a) :: set_sync => c_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_c_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_c_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_c_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_c_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: clip_d_ip => psb_c_clip_d_ip + procedure, pass(a) :: clip_d => psb_c_clip_d + generic, public :: clip_diag => clip_d_ip, clip_d + procedure, pass(a) :: cscnv_np => psb_c_cscnv + procedure, pass(a) :: cscnv_ip => psb_c_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_c_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_cspmat_clone + ! + ! To/from lc + ! + procedure, pass(a) :: mv_from_lb => psb_c_mv_from_lb + procedure, pass(a) :: mv_to_lb => psb_c_mv_to_lb + procedure, pass(a) :: cp_from_lb => psb_c_cp_from_lb + procedure, pass(a) :: cp_to_lb => psb_c_cp_to_lb + procedure, pass(a) :: mv_from_l => psb_c_mv_from_l + procedure, pass(a) :: mv_to_l => psb_c_mv_to_l + procedure, pass(a) :: cp_from_l => psb_c_cp_from_l + procedure, pass(a) :: cp_to_l => psb_c_cp_to_l + generic, public :: mv_from => mv_from_lb, mv_from_l + generic, public :: mv_to => mv_to_lb, mv_to_l + generic, public :: cp_from => cp_from_lb, cp_from_l + generic, public :: cp_to => cp_to_lb, cp_to_l + + ! Computational routines + procedure, pass(a) :: get_diag => psb_c_get_diag + procedure, pass(a) :: maxval => psb_c_maxval + procedure, pass(a) :: spnmi => psb_c_csnmi + procedure, pass(a) :: spnm1 => psb_c_csnm1 + procedure, pass(a) :: rowsum => psb_c_rowsum + procedure, pass(a) :: arwsum => psb_c_arwsum + procedure, pass(a) :: colsum => psb_c_colsum + procedure, pass(a) :: aclsum => psb_c_aclsum + procedure, pass(a) :: csmv_v => psb_c_csmv_vect + procedure, pass(a) :: csmv => psb_c_csmv + procedure, pass(a) :: csmm => psb_c_csmm + generic, public :: spmm => csmm, csmv, csmv_v + procedure, pass(a) :: scals => psb_c_scals + procedure, pass(a) :: scalv => psb_c_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: cssv_v => psb_c_cssv_vect + procedure, pass(a) :: cssv => psb_c_cssv + procedure, pass(a) :: cssm => psb_c_cssm + generic, public :: spsm => cssm, cssv, cssv_v + + end type psb_cspmat_type + + private :: psb_c_get_nrows, psb_c_get_ncols, & + & psb_c_get_nzeros, psb_c_get_size, & + & psb_c_get_dupl, psb_c_is_null, psb_c_is_bld, & + & psb_c_is_upd, psb_c_is_asb, psb_c_is_sorted, & + & psb_c_is_by_rows, psb_c_is_by_cols, psb_c_is_upper, & + & psb_c_is_lower, psb_c_is_triangle, psb_c_get_nz_row, & + & c_mat_sync, c_mat_is_host, c_mat_is_dev, & + & c_mat_is_sync, c_mat_set_host, c_mat_set_dev,& + & c_mat_set_sync + + + + class(psb_c_base_sparse_mat), allocatable, target, & + & save, private :: psb_c_base_mat_default + + interface psb_set_mat_default + module procedure psb_c_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_c_get_mat_default + end interface + + interface psb_sizeof + module procedure psb_c_sizeof + end interface + + + type :: psb_lcspmat_type + + class(psb_lc_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_lc_get_nrows + procedure, pass(a) :: get_ncols => psb_lc_get_ncols + procedure, pass(a) :: get_nzeros => psb_lc_get_nzeros + procedure, pass(a) :: get_nz_row => psb_lc_get_nz_row + procedure, pass(a) :: get_size => psb_lc_get_size + procedure, pass(a) :: get_dupl => psb_lc_get_dupl + procedure, pass(a) :: is_null => psb_lc_is_null + procedure, pass(a) :: is_bld => psb_lc_is_bld + procedure, pass(a) :: is_upd => psb_lc_is_upd + procedure, pass(a) :: is_asb => psb_lc_is_asb + procedure, pass(a) :: is_sorted => psb_lc_is_sorted + procedure, pass(a) :: is_by_rows => psb_lc_is_by_rows + procedure, pass(a) :: is_by_cols => psb_lc_is_by_cols + procedure, pass(a) :: is_upper => psb_lc_is_upper + procedure, pass(a) :: is_lower => psb_lc_is_lower + procedure, pass(a) :: is_triangle => psb_lc_is_triangle + procedure, pass(a) :: is_unit => psb_lc_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_lc_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_lc_get_fmt + procedure, pass(a) :: sizeof => psb_lc_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_lc_set_nrows + procedure, pass(a) :: set_ncols => psb_lc_set_ncols + procedure, pass(a) :: set_dupl => psb_lc_set_dupl + procedure, pass(a) :: set_null => psb_lc_set_null + procedure, pass(a) :: set_bld => psb_lc_set_bld + procedure, pass(a) :: set_upd => psb_lc_set_upd + procedure, pass(a) :: set_asb => psb_lc_set_asb + procedure, pass(a) :: set_sorted => psb_lc_set_sorted + procedure, pass(a) :: set_upper => psb_lc_set_upper + procedure, pass(a) :: set_lower => psb_lc_set_lower + procedure, pass(a) :: set_triangle => psb_lc_set_triangle + procedure, pass(a) :: set_unit => psb_lc_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_lc_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_lc_csall + procedure, pass(a) :: free => psb_lc_free + procedure, pass(a) :: trim => psb_lc_trim + procedure, pass(a) :: csput_a => psb_lc_csput_a + procedure, pass(a) :: csput_v => psb_lc_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_lc_csgetptn + procedure, pass(a) :: csgetrow => psb_lc_csgetrow + procedure, pass(a) :: csgetblk => psb_lc_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: icsgetptn => psb_lc_icsgetptn + procedure, pass(a) :: icsgetrow => psb_lc_icsgetrow + generic, public :: csget => icsgetptn, icsgetrow +#endif + procedure, pass(a) :: tril => psb_lc_tril + procedure, pass(a) :: triu => psb_lc_triu + procedure, pass(a) :: m_csclip => psb_lc_csclip + procedure, pass(a) :: b_csclip => psb_lc_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_lc_clean_zeros + procedure, pass(a) :: reall => psb_lc_reallocate_nz + procedure, pass(a) :: get_neigh => psb_lc_get_neigh + procedure, pass(a) :: reinit => psb_lc_reinit + procedure, pass(a) :: print_i => psb_lc_sparse_print + procedure, pass(a) :: print_n => psb_lc_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_lc_mold + procedure, pass(a) :: asb => psb_lc_asb + procedure, pass(a) :: transp_1mat => psb_lc_transp_1mat + procedure, pass(a) :: transp_2mat => psb_lc_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_lc_transc_1mat + procedure, pass(a) :: transc_2mat => psb_lc_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => lc_mat_sync + procedure, pass(a) :: is_host => lc_mat_is_host + procedure, pass(a) :: is_dev => lc_mat_is_dev + procedure, pass(a) :: is_sync => lc_mat_is_sync + procedure, pass(a) :: set_host => lc_mat_set_host + procedure, pass(a) :: set_dev => lc_mat_set_dev + procedure, pass(a) :: set_sync => lc_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_lc_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_lc_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_lc_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_lc_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: cscnv_np => psb_lc_cscnv + procedure, pass(a) :: cscnv_ip => psb_lc_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_lc_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_lcspmat_clone + ! + ! To/from c + ! + procedure, pass(a) :: mv_from_ib => psb_lc_mv_from_ib + procedure, pass(a) :: mv_to_ib => psb_lc_mv_to_ib + procedure, pass(a) :: cp_from_ib => psb_lc_cp_from_ib + procedure, pass(a) :: cp_to_ib => psb_lc_cp_to_ib + procedure, pass(a) :: mv_from_i => psb_lc_mv_from_i + procedure, pass(a) :: mv_to_i => psb_lc_mv_to_i + procedure, pass(a) :: cp_from_i => psb_lc_cp_from_i + procedure, pass(a) :: cp_to_i => psb_lc_cp_to_i + generic, public :: mv_from => mv_from_ib, mv_from_i + generic, public :: mv_to => mv_to_ib, mv_to_i + generic, public :: cp_from => cp_from_ib, cp_from_i + generic, public :: cp_to => cp_to_ib, cp_to_i + + ! Computational routines + procedure, pass(a) :: get_diag => psb_lc_get_diag + procedure, pass(a) :: maxval => psb_lc_maxval + procedure, pass(a) :: spnmi => psb_lc_csnmi + procedure, pass(a) :: spnm1 => psb_lc_csnm1 + procedure, pass(a) :: rowsum => psb_lc_rowsum + procedure, pass(a) :: arwsum => psb_lc_arwsum + procedure, pass(a) :: colsum => psb_lc_colsum + procedure, pass(a) :: aclsum => psb_lc_aclsum + procedure, pass(a) :: scals => psb_lc_scals + procedure, pass(a) :: scalv => psb_lc_scal + generic, public :: scal => scals, scalv + + end type psb_lcspmat_type + + private :: psb_lc_get_nrows, psb_lc_get_ncols, & + & psb_lc_get_nzeros, psb_lc_get_size, & + & psb_lc_get_dupl, psb_lc_is_null, psb_lc_is_bld, & + & psb_lc_is_upd, psb_lc_is_asb, psb_lc_is_sorted, & + & psb_lc_is_by_rows, psb_lc_is_by_cols, psb_lc_is_upper, & + & psb_lc_is_lower, psb_lc_is_triangle, psb_lc_get_nz_row, & + & lc_mat_sync, lc_mat_is_host, lc_mat_is_dev, & + & lc_mat_is_sync, lc_mat_set_host, lc_mat_set_dev,& + & lc_mat_set_sync + + + + class(psb_lc_base_sparse_mat), allocatable, target, & + & save, private :: psb_lc_base_mat_default + + interface psb_set_mat_default + module procedure psb_lc_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_lc_get_mat_default + end interface + + + ! == =================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == =================================== + + + interface + subroutine psb_c_set_nrows(m,a) + import :: psb_ipk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: m + end subroutine psb_c_set_nrows + end interface + + interface + subroutine psb_c_set_ncols(n,a) + import :: psb_ipk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_c_set_ncols + end interface + + interface + subroutine psb_c_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_c_set_dupl + end interface + + interface + subroutine psb_c_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_set_null + end interface + + interface + subroutine psb_c_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_set_bld + end interface + + interface + subroutine psb_c_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_set_upd + end interface + + interface + subroutine psb_c_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_set_asb + end interface + + interface + subroutine psb_c_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_sorted + end interface + + interface + subroutine psb_c_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_triangle + end interface + + interface + subroutine psb_c_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_unit + end interface + + interface + subroutine psb_c_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_lower + end interface + + interface + subroutine psb_c_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_c_set_upper + end interface + + interface + subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_c_sparse_print + end interface + + interface + subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + character(len=*), intent(in) :: fname + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_c_n_sparse_print + end interface + + interface + subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n + integer(psb_ipk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: lev + end subroutine psb_c_get_neigh + end interface + + interface + subroutine psb_c_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: nz + end subroutine psb_c_csall + end interface + + interface + subroutine psb_c_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + integer(psb_ipk_), intent(in) :: nz + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_reallocate_nz + end interface + + interface + subroutine psb_c_free(a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_free + end interface + + interface + subroutine psb_c_trim(a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_trim + end interface + + interface + subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_c_csput_a + end interface + + + interface + subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_vect_mod, only : psb_c_vect_type + use psb_i_vect_mod, only : psb_i_vect_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + type(psb_c_vect_type), intent(inout) :: val + type(psb_i_vect_type), intent(inout) :: ia, ja + integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_c_csput_v + end interface + + interface + subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csgetptn + end interface + + interface + subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csgetrow + end interface + + interface + subroutine psb_c_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csgetblk + end interface + + interface + subroutine psb_c_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_cspmat_type), optional, intent(inout) :: u + end subroutine psb_c_tril + end interface + + interface + subroutine psb_c_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_cspmat_type), optional, intent(inout) :: l + end subroutine psb_c_triu + end interface + + + interface + subroutine psb_c_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_csclip + end interface + + interface + subroutine psb_c_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_coo_sparse_mat + class(psb_cspmat_type), intent(in) :: a + type(psb_c_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_c_b_csclip + end interface + + interface + subroutine psb_c_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_c_mold + end interface + + interface + subroutine psb_c_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_c_asb + end interface + + interface + subroutine psb_c_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_transp_1mat + end interface + + interface + subroutine psb_c_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: b + end subroutine psb_c_transp_2mat + end interface + + interface + subroutine psb_c_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + end subroutine psb_c_transc_1mat + end interface + + interface + subroutine psb_c_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: b + end subroutine psb_c_transc_2mat + end interface + + interface + subroutine psb_c_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_c_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_c_cscnv + end interface + + + interface + subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_c_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_c_cscnv_ip + end interface + + + interface + subroutine psb_c_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(in) :: a + class(psb_c_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_c_cscnv_base + end interface + + ! + ! Produce a version of the matrix with diagonal cut + ! out; passes through a COO buffer. + ! + interface + subroutine psb_c_clip_d(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + end subroutine psb_c_clip_d + end interface + + interface + subroutine psb_c_clip_d_ip(a,info) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + end subroutine psb_c_clip_d_ip + end interface + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_c_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + end subroutine psb_c_mv_from + end interface + + interface + subroutine psb_c_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(out) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + end subroutine psb_c_cp_from + end interface + + interface + subroutine psb_c_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + end subroutine psb_c_mv_to + end interface + + interface + subroutine psb_c_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_cspmat_type), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + end subroutine psb_c_cp_to + end interface + ! + ! Mixed type conversions + ! + interface + subroutine psb_c_mv_from_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_cspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_c_mv_from_lb + end interface + + interface + subroutine psb_c_cp_from_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_cspmat_type), intent(out) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + end subroutine psb_c_cp_from_lb + end interface + + interface + subroutine psb_c_mv_to_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_cspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_c_mv_to_lb + end interface + + interface + subroutine psb_c_cp_to_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_cspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_c_cp_to_lb + end interface + + interface + subroutine psb_c_mv_from_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lcspmat_type + class(psb_cspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + end subroutine psb_c_mv_from_l + end interface + + interface + subroutine psb_c_cp_from_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lcspmat_type + class(psb_cspmat_type), intent(out) :: a + class(psb_lcspmat_type), intent(in) :: b + end subroutine psb_c_cp_from_l + end interface + + interface + subroutine psb_c_mv_to_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lcspmat_type + class(psb_cspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + end subroutine psb_c_mv_to_l + end interface + + interface + subroutine psb_c_cp_to_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_lcspmat_type + class(psb_cspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + end subroutine psb_c_cp_to_l + end interface + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_cspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cspmat_type_move + end interface + + interface + subroutine psb_cspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cspmat_clone + end interface + + + + + ! == =================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + ! == =================================== + + interface psb_csmm + subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_csmm + subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_csmv + subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans) + use psb_c_vect_mod, only : psb_c_vect_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_c_vect_type), intent(inout) :: x + type(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_c_csmv_vect + end interface + + interface psb_cssm + subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_spk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_c_cssm + subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta, x(:) + complex(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_c_cssv + subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) + use psb_c_vect_mod, only : psb_c_vect_type + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), intent(in) :: alpha, beta + type(psb_c_vect_type), intent(inout) :: x + type(psb_c_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + type(psb_c_vect_type), optional, intent(inout) :: d + end subroutine psb_c_cssv_vect + end interface + + interface + function psb_c_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_c_maxval + end interface + + interface + function psb_c_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_c_csnmi + end interface + + interface + function psb_c_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_c_csnm1 + end interface + + interface + function psb_c_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_c_rowsum + end interface + + interface + function psb_c_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_c_arwsum + end interface + + interface + function psb_c_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_c_colsum + end interface + + interface + function psb_c_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_c_aclsum + end interface + + interface + function psb_c_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_c_get_diag + end interface + + interface psb_scal + subroutine psb_c_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_c_scal + subroutine psb_c_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_ + class(psb_cspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_scals + end interface + + + ! == =================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == =================================== + + + interface + subroutine psb_lc_set_nrows(m,a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + end subroutine psb_lc_set_nrows + end interface + + interface + subroutine psb_lc_set_ncols(n,a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + end subroutine psb_lc_set_ncols + end interface + + interface + subroutine psb_lc_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_lc_set_dupl + end interface + + interface + subroutine psb_lc_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_set_null + end interface + + interface + subroutine psb_lc_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_set_bld + end interface + + interface + subroutine psb_lc_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_set_upd + end interface + + interface + subroutine psb_lc_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_set_asb + end interface + + interface + subroutine psb_lc_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_sorted + end interface + + interface + subroutine psb_lc_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_triangle + end interface + + interface + subroutine psb_lc_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_unit + end interface + + interface + subroutine psb_lc_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_lower + end interface + + interface + subroutine psb_lc_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lc_set_upper + end interface + + interface + subroutine psb_lc_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_sparse_print + end interface + + interface + subroutine psb_lc_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + character(len=*), intent(in) :: fname + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lc_n_sparse_print + end interface + + interface + subroutine psb_lc_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_lc_get_neigh + end interface + + interface + subroutine psb_lc_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lc_csall + end interface + + interface + subroutine psb_lc_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + integer(psb_lpk_), intent(in) :: nz + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_reallocate_nz + end interface + + interface + subroutine psb_lc_free(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_free + end interface + + interface + subroutine psb_lc_trim(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_trim + end interface + + interface + subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_csput_a + end interface + + + interface + subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_vect_mod, only : psb_c_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + type(psb_c_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lc_csput_v + end interface + + interface + subroutine psb_lc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csgetptn + end interface + + interface + subroutine psb_lc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csgetrow + end interface + + interface + subroutine psb_lc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csgetblk + end interface + + interface + subroutine psb_lc_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lcspmat_type), optional, intent(inout) :: u + end subroutine psb_lc_tril + end interface + + interface + subroutine psb_lc_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lcspmat_type), optional, intent(inout) :: l + end subroutine psb_lc_triu + end interface + + + interface + subroutine psb_lc_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_csclip + end interface + + interface + subroutine psb_lc_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_coo_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + type(psb_lc_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lc_b_csclip + end interface + + interface + subroutine psb_lc_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_lc_mold + end interface + + interface + subroutine psb_lc_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_lc_asb + end interface + + interface + subroutine psb_lc_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_transp_1mat + end interface + + interface + subroutine psb_lc_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + end subroutine psb_lc_transp_2mat + end interface + + interface + subroutine psb_lc_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + end subroutine psb_lc_transc_1mat + end interface + + interface + subroutine psb_lc_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + end subroutine psb_lc_transc_2mat + end interface + + interface + subroutine psb_lc_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lc_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_lc_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_lc_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_lc_cscnv + end interface + + + interface + subroutine psb_lc_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_lc_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_lc_cscnv_ip + end interface + + + interface + subroutine psb_lc_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_lc_cscnv_base + end interface + + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_lc_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_mv_from + end interface + + interface + subroutine psb_lc_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(out) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + end subroutine psb_lc_cp_from + end interface + + interface + subroutine psb_lc_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_mv_to + end interface + + interface + subroutine psb_lc_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_lc_base_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_cp_to + end interface + ! + ! Mixed type conversions + ! + interface + subroutine psb_lc_mv_from_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_mv_from_ib + end interface + + interface + subroutine psb_lc_cp_from_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_lcspmat_type), intent(out) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + end subroutine psb_lc_cp_from_ib + end interface + + interface + subroutine psb_lc_mv_to_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_lcspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_mv_to_ib + end interface + + interface + subroutine psb_lc_cp_to_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_c_base_sparse_mat + class(psb_lcspmat_type), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + end subroutine psb_lc_cp_to_ib + end interface + + interface + subroutine psb_lc_mv_from_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_cspmat_type + class(psb_lcspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + end subroutine psb_lc_mv_from_i + end interface + + interface + subroutine psb_lc_cp_from_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_cspmat_type + class(psb_lcspmat_type), intent(out) :: a + class(psb_cspmat_type), intent(in) :: b + end subroutine psb_lc_cp_from_i + end interface + + interface + subroutine psb_lc_mv_to_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_cspmat_type + class(psb_lcspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + end subroutine psb_lc_mv_to_i + end interface + + interface + subroutine psb_lc_cp_to_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_, psb_cspmat_type + class(psb_lcspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: b + end subroutine psb_lc_cp_to_i + end interface + + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_lcspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lcspmat_type_move + end interface + + interface + subroutine psb_lcspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lcspmat_clone + end interface + + + + interface + function psb_lc_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_get_diag + end interface + + interface psb_scal + subroutine psb_lc_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lc_scal + subroutine psb_lc_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lc_scals + end interface + + interface + function psb_lc_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_maxval + end interface + + interface + function psb_lc_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csnmi + end interface + + interface + function psb_lc_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_lc_csnm1 + end interface + + interface + function psb_lc_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_rowsum + end interface + + interface + function psb_lc_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_arwsum + end interface + + interface + function psb_lc_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_colsum + end interface + + interface + function psb_lc_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lcspmat_type, psb_spk_ + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lc_aclsum + end interface + +contains + + subroutine psb_c_set_mat_default(a) + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + + if (allocated(psb_c_base_mat_default)) then + deallocate(psb_c_base_mat_default) + end if + allocate(psb_c_base_mat_default, mold=a) + + end subroutine psb_c_set_mat_default + + function psb_c_get_mat_default(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + class(psb_c_base_sparse_mat), pointer :: res + + res => psb_c_get_base_mat_default() + + end function psb_c_get_mat_default + + + function psb_c_get_base_mat_default() result(res) + implicit none + class(psb_c_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_c_base_mat_default)) then + allocate(psb_c_csr_sparse_mat :: psb_c_base_mat_default) + end if + + res => psb_c_base_mat_default + + end function psb_c_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_c_sizeof(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_c_sizeof + + + function psb_c_get_fmt(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_c_get_fmt + + + function psb_c_get_dupl(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_c_get_dupl + + function psb_c_get_nrows(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_c_get_nrows + + function psb_c_get_ncols(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_c_get_ncols + + function psb_c_is_triangle(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_c_is_triangle + + function psb_c_is_unit(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_c_is_unit + + function psb_c_is_upper(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_c_is_upper + + function psb_c_is_lower(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_c_is_lower + + function psb_c_is_null(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_c_is_null + + function psb_c_is_bld(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_c_is_bld + + function psb_c_is_upd(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_c_is_upd + + function psb_c_is_asb(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_c_is_asb + + function psb_c_is_sorted(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_c_is_sorted + + function psb_c_is_by_rows(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_c_is_by_rows + + function psb_c_is_by_cols(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_c_is_by_cols + + + ! + subroutine c_mat_sync(a) + implicit none + class(psb_cspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine c_mat_sync + + ! + subroutine c_mat_set_host(a) + implicit none + class(psb_cspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine c_mat_set_host + + + ! + subroutine c_mat_set_dev(a) + implicit none + class(psb_cspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine c_mat_set_dev + + ! + subroutine c_mat_set_sync(a) + implicit none + class(psb_cspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine c_mat_set_sync + + ! + function c_mat_is_dev(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function c_mat_is_dev + + ! + function c_mat_is_host(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function c_mat_is_host + + ! + function c_mat_is_sync(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function c_mat_is_sync + + + function psb_c_is_repeatable_updates(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_c_is_repeatable_updates + + subroutine psb_c_set_repeatable_updates(a,val) + implicit none + class(psb_cspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_c_set_repeatable_updates + + + function psb_c_get_nzeros(a) result(res) + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_c_get_nzeros + + function psb_c_get_size(a) result(res) + + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_c_get_size + + + function psb_c_get_nz_row(idx,a) result(res) + implicit none + integer(psb_ipk_), intent(in) :: idx + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_c_get_nz_row + + subroutine psb_c_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_cspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_c_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_c_lcsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_c_lcsgetptn + + subroutine psb_c_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_cspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_c_lcsgetrow +#endif + + ! + ! lc methods + ! + + + subroutine psb_lc_set_mat_default(a) + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + + if (allocated(psb_lc_base_mat_default)) then + deallocate(psb_lc_base_mat_default) + end if + allocate(psb_lc_base_mat_default, mold=a) + + end subroutine psb_lc_set_mat_default + + function psb_lc_get_mat_default(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), pointer :: res + + res => psb_lc_get_base_mat_default() + + end function psb_lc_get_mat_default + + + function psb_lc_get_base_mat_default() result(res) + implicit none + class(psb_lc_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_lc_base_mat_default)) then + allocate(psb_lc_csr_sparse_mat :: psb_lc_base_mat_default) + end if + + res => psb_lc_base_mat_default + + end function psb_lc_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_lc_sizeof(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_lc_sizeof + + + function psb_lc_get_fmt(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_lc_get_fmt + + + function psb_lc_get_dupl(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_lc_get_dupl + + function psb_lc_get_nrows(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_lc_get_nrows + + function psb_lc_get_ncols(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_lc_get_ncols + + function psb_lc_is_triangle(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_lc_is_triangle + + function psb_lc_is_unit(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_lc_is_unit + + function psb_lc_is_upper(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_lc_is_upper + + function psb_lc_is_lower(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_lc_is_lower + + function psb_lc_is_null(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_lc_is_null + + function psb_lc_is_bld(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_lc_is_bld + + function psb_lc_is_upd(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_lc_is_upd + + function psb_lc_is_asb(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_lc_is_asb + + function psb_lc_is_sorted(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_lc_is_sorted + + function psb_lc_is_by_rows(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_lc_is_by_rows + + function psb_lc_is_by_cols(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_lc_is_by_cols + + + ! + subroutine lc_mat_sync(a) + implicit none + class(psb_lcspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine lc_mat_sync + + ! + subroutine lc_mat_set_host(a) + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine lc_mat_set_host + + + ! + subroutine lc_mat_set_dev(a) + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine lc_mat_set_dev + + ! + subroutine lc_mat_set_sync(a) + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine lc_mat_set_sync + + ! + function lc_mat_is_dev(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function lc_mat_is_dev + + ! + function lc_mat_is_host(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function lc_mat_is_host + + ! + function lc_mat_is_sync(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function lc_mat_is_sync + + + function psb_lc_is_repeatable_updates(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_lc_is_repeatable_updates + + subroutine psb_lc_set_repeatable_updates(a,val) + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_lc_set_repeatable_updates + + + function psb_lc_get_nzeros(a) result(res) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_lc_get_nzeros + + function psb_lc_get_size(a) result(res) + + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_lc_get_size + + + function psb_lc_get_nz_row(idx,a) result(res) + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_lc_get_nz_row + + subroutine psb_lc_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_lcspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_lc_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_lc_icsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_lc_icsgetptn + + subroutine psb_lc_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_lc_icsgetrow +#endif + +end module psb_c_mat_mod diff --git a/base/modules/serial/psb_c_mat_mod.f90 b/base/modules/serial/psb_c_mat_mod.f90 deleted file mode 100644 index 70c9bbb51..000000000 --- a/base/modules/serial/psb_c_mat_mod.f90 +++ /dev/null @@ -1,1296 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! package: psb_c_mat_mod -! -! This module contains the definition of the psb_c_sparse type which -! is a generic container for a sparse matrix and it is mostly meant to -! provide a mean of switching, at run-time, among different formats, -! potentially unknown at the library compile-time by adding a layer of -! indirection. This type encapsulates the psb_c_base_sparse_mat class -! inside another class which is the one visible to the user. -! Most methods of the psb_c_mat_mod simply call the methods of the -! encapsulated class. -! The exceptions are mainly cscnv and cp_from/cp_to; these provide -! the functionalities to have the encapsulated class change its -! type dynamically, and to extract/input an inner object. -! -! A sparse matrix has a state corresponding to its progression -! through the application life. -! In particular, computational methods can only be invoked when -! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the -! following state transition table. Associated with these states are -! the possible dynamic types of the inner matrix object. -! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method -!| ---------------------------------- -!| Null Build csall -!| Build Build csput -!| Build Assembled cscnv -!| Assembled Assembled cscnv -!| Assembled Update reinit -!| Update Update csput -!| Update Assembled cscnv -!| * unchanged reall -!| Assembled Null free -! - - -module psb_c_mat_mod - - use psb_c_base_mat_mod - use psb_c_csr_mat_mod, only : psb_c_csr_sparse_mat - use psb_c_csc_mat_mod, only : psb_c_csc_sparse_mat - - type :: psb_cspmat_type - - class(psb_c_base_sparse_mat), allocatable :: a - - contains - ! Getters - procedure, pass(a) :: get_nrows => psb_c_get_nrows - procedure, pass(a) :: get_ncols => psb_c_get_ncols - procedure, pass(a) :: get_nzeros => psb_c_get_nzeros - procedure, pass(a) :: get_nz_row => psb_c_get_nz_row - procedure, pass(a) :: get_size => psb_c_get_size - procedure, pass(a) :: get_dupl => psb_c_get_dupl - procedure, pass(a) :: is_null => psb_c_is_null - procedure, pass(a) :: is_bld => psb_c_is_bld - procedure, pass(a) :: is_upd => psb_c_is_upd - procedure, pass(a) :: is_asb => psb_c_is_asb - procedure, pass(a) :: is_sorted => psb_c_is_sorted - procedure, pass(a) :: is_by_rows => psb_c_is_by_rows - procedure, pass(a) :: is_by_cols => psb_c_is_by_cols - procedure, pass(a) :: is_upper => psb_c_is_upper - procedure, pass(a) :: is_lower => psb_c_is_lower - procedure, pass(a) :: is_triangle => psb_c_is_triangle - procedure, pass(a) :: is_unit => psb_c_is_unit - procedure, pass(a) :: is_repeatable_updates => psb_c_is_repeatable_updates - procedure, pass(a) :: get_fmt => psb_c_get_fmt - procedure, pass(a) :: sizeof => psb_c_sizeof - - ! Setters - procedure, pass(a) :: set_nrows => psb_c_set_nrows - procedure, pass(a) :: set_ncols => psb_c_set_ncols - procedure, pass(a) :: set_dupl => psb_c_set_dupl - procedure, pass(a) :: set_null => psb_c_set_null - procedure, pass(a) :: set_bld => psb_c_set_bld - procedure, pass(a) :: set_upd => psb_c_set_upd - procedure, pass(a) :: set_asb => psb_c_set_asb - procedure, pass(a) :: set_sorted => psb_c_set_sorted - procedure, pass(a) :: set_upper => psb_c_set_upper - procedure, pass(a) :: set_lower => psb_c_set_lower - procedure, pass(a) :: set_triangle => psb_c_set_triangle - procedure, pass(a) :: set_unit => psb_c_set_unit - procedure, pass(a) :: set_repeatable_updates => psb_c_set_repeatable_updates - - ! Memory/data management - procedure, pass(a) :: csall => psb_c_csall - procedure, pass(a) :: free => psb_c_free - procedure, pass(a) :: trim => psb_c_trim - procedure, pass(a) :: csput_a => psb_c_csput_a - procedure, pass(a) :: csput_v => psb_c_csput_v - generic, public :: csput => csput_a, csput_v - procedure, pass(a) :: csgetptn => psb_c_csgetptn - procedure, pass(a) :: csgetrow => psb_c_csgetrow - procedure, pass(a) :: csgetblk => psb_c_csgetblk - generic, public :: csget => csgetptn, csgetrow, csgetblk - procedure, pass(a) :: tril => psb_c_tril - procedure, pass(a) :: triu => psb_c_triu - procedure, pass(a) :: m_csclip => psb_c_csclip - procedure, pass(a) :: b_csclip => psb_c_b_csclip - generic, public :: csclip => b_csclip, m_csclip - procedure, pass(a) :: clean_zeros => psb_c_clean_zeros - procedure, pass(a) :: reall => psb_c_reallocate_nz - procedure, pass(a) :: get_neigh => psb_c_get_neigh - procedure, pass(a) :: reinit => psb_c_reinit - procedure, pass(a) :: print_i => psb_c_sparse_print - procedure, pass(a) :: print_n => psb_c_n_sparse_print - generic, public :: print => print_i, print_n - procedure, pass(a) :: mold => psb_c_mold - procedure, pass(a) :: asb => psb_c_asb - procedure, pass(a) :: transp_1mat => psb_c_transp_1mat - procedure, pass(a) :: transp_2mat => psb_c_transp_2mat - generic, public :: transp => transp_1mat, transp_2mat - procedure, pass(a) :: transc_1mat => psb_c_transc_1mat - procedure, pass(a) :: transc_2mat => psb_c_transc_2mat - generic, public :: transc => transc_1mat, transc_2mat - - ! - ! Sync: centerpiece of handling of external storage. - ! Any derived class having extra storage upon sync - ! will guarantee that both fortran/host side and - ! external side contain the same data. The base - ! version is only a placeholder. - ! - procedure, pass(a) :: sync => c_mat_sync - procedure, pass(a) :: is_host => c_mat_is_host - procedure, pass(a) :: is_dev => c_mat_is_dev - procedure, pass(a) :: is_sync => c_mat_is_sync - procedure, pass(a) :: set_host => c_mat_set_host - procedure, pass(a) :: set_dev => c_mat_set_dev - procedure, pass(a) :: set_sync => c_mat_set_sync - - - ! These are specific to this level of encapsulation. - procedure, pass(a) :: mv_from_b => psb_c_mv_from - generic, public :: mv_from => mv_from_b - procedure, pass(a) :: mv_to_b => psb_c_mv_to - generic, public :: mv_to => mv_to_b - procedure, pass(a) :: cp_from_b => psb_c_cp_from - generic, public :: cp_from => cp_from_b - procedure, pass(a) :: cp_to_b => psb_c_cp_to - generic, public :: cp_to => cp_to_b - procedure, pass(a) :: clip_d_ip => psb_c_clip_d_ip - procedure, pass(a) :: clip_d => psb_c_clip_d - generic, public :: clip_diag => clip_d_ip, clip_d - procedure, pass(a) :: cscnv_np => psb_c_cscnv - procedure, pass(a) :: cscnv_ip => psb_c_cscnv_ip - procedure, pass(a) :: cscnv_base => psb_c_cscnv_base - generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base - procedure, pass(a) :: clone => psb_cspmat_clone - - ! Computational routines - procedure, pass(a) :: get_diag => psb_c_get_diag - procedure, pass(a) :: maxval => psb_c_maxval - procedure, pass(a) :: spnmi => psb_c_csnmi - procedure, pass(a) :: spnm1 => psb_c_csnm1 - procedure, pass(a) :: rowsum => psb_c_rowsum - procedure, pass(a) :: arwsum => psb_c_arwsum - procedure, pass(a) :: colsum => psb_c_colsum - procedure, pass(a) :: aclsum => psb_c_aclsum - procedure, pass(a) :: csmv_v => psb_c_csmv_vect - procedure, pass(a) :: csmv => psb_c_csmv - procedure, pass(a) :: csmm => psb_c_csmm - generic, public :: spmm => csmm, csmv, csmv_v - procedure, pass(a) :: scals => psb_c_scals - procedure, pass(a) :: scalv => psb_c_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: cssv_v => psb_c_cssv_vect - procedure, pass(a) :: cssv => psb_c_cssv - procedure, pass(a) :: cssm => psb_c_cssm - generic, public :: spsm => cssm, cssv, cssv_v - - end type psb_cspmat_type - - private :: psb_c_get_nrows, psb_c_get_ncols, & - & psb_c_get_nzeros, psb_c_get_size, & - & psb_c_get_dupl, psb_c_is_null, psb_c_is_bld, & - & psb_c_is_upd, psb_c_is_asb, psb_c_is_sorted, & - & psb_c_is_by_rows, psb_c_is_by_cols, psb_c_is_upper, & - & psb_c_is_lower, psb_c_is_triangle, psb_c_get_nz_row, & - & c_mat_sync, c_mat_is_host, c_mat_is_dev, & - & c_mat_is_sync, c_mat_set_host, c_mat_set_dev,& - & c_mat_set_sync - - - - class(psb_c_base_sparse_mat), allocatable, target, & - & save, private :: psb_c_base_mat_default - - interface psb_set_mat_default - module procedure psb_c_set_mat_default - end interface - - interface psb_get_mat_default - module procedure psb_c_get_mat_default - end interface - - interface psb_sizeof - module procedure psb_c_sizeof - end interface - - - ! == =================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - ! == =================================== - - - interface - subroutine psb_c_set_nrows(m,a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: m - end subroutine psb_c_set_nrows - end interface - - interface - subroutine psb_c_set_ncols(n,a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_c_set_ncols - end interface - - interface - subroutine psb_c_set_dupl(n,a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_c_set_dupl - end interface - - interface - subroutine psb_c_set_null(a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_set_null - end interface - - interface - subroutine psb_c_set_bld(a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_set_bld - end interface - - interface - subroutine psb_c_set_upd(a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_set_upd - end interface - - interface - subroutine psb_c_set_asb(a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_set_asb - end interface - - interface - subroutine psb_c_set_sorted(a,val) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_c_set_sorted - end interface - - interface - subroutine psb_c_set_triangle(a,val) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_c_set_triangle - end interface - - interface - subroutine psb_c_set_unit(a,val) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_c_set_unit - end interface - - interface - subroutine psb_c_set_lower(a,val) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_c_set_lower - end interface - - interface - subroutine psb_c_set_upper(a,val) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_c_set_upper - end interface - - interface - subroutine psb_c_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_cspmat_type - integer(psb_ipk_), intent(in) :: iout - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_c_sparse_print - end interface - - interface - subroutine psb_c_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_cspmat_type - character(len=*), intent(in) :: fname - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_c_n_sparse_print - end interface - - interface - subroutine psb_c_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n - integer(psb_ipk_), allocatable, intent(out) :: neigh(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev - end subroutine psb_c_get_neigh - end interface - - interface - subroutine psb_c_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nr,nc - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: nz - end subroutine psb_c_csall - end interface - - interface - subroutine psb_c_reallocate_nz(nz,a) - import :: psb_ipk_, psb_cspmat_type - integer(psb_ipk_), intent(in) :: nz - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_reallocate_nz - end interface - - interface - subroutine psb_c_free(a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_free - end interface - - interface - subroutine psb_c_trim(a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_trim - end interface - - interface - subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(inout) :: a - complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_c_csput_a - end interface - - - interface - subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_c_vect_mod, only : psb_c_vect_type - use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - type(psb_c_vect_type), intent(inout) :: val - type(psb_i_vect_type), intent(inout) :: ia, ja - integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_c_csput_v - end interface - - interface - subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_c_csgetptn - end interface - - interface - subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale,chksz - end subroutine psb_c_csgetrow - end interface - - interface - subroutine psb_c_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - class(psb_cspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_c_csgetblk - end interface - - interface - subroutine psb_c_tril(a,l,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - class(psb_cspmat_type), intent(inout) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_cspmat_type), optional, intent(inout) :: u - end subroutine psb_c_tril - end interface - - interface - subroutine psb_c_triu(a,u,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - class(psb_cspmat_type), intent(inout) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_cspmat_type), optional, intent(inout) :: l - end subroutine psb_c_triu - end interface - - - interface - subroutine psb_c_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - class(psb_cspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_c_csclip - end interface - - interface - subroutine psb_c_b_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_coo_sparse_mat - class(psb_cspmat_type), intent(in) :: a - type(psb_c_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_c_b_csclip - end interface - - interface - subroutine psb_c_mold(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(inout) :: a - class(psb_c_base_sparse_mat), allocatable, intent(out) :: b - end subroutine psb_c_mold - end interface - - interface - subroutine psb_c_asb(a,mold) - import :: psb_ipk_, psb_cspmat_type, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(inout) :: a - class(psb_c_base_sparse_mat), optional, intent(in) :: mold - end subroutine psb_c_asb - end interface - - interface - subroutine psb_c_transp_1mat(a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_transp_1mat - end interface - - interface - subroutine psb_c_transp_2mat(a,b) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(in) :: a - class(psb_cspmat_type), intent(inout) :: b - end subroutine psb_c_transp_2mat - end interface - - interface - subroutine psb_c_transc_1mat(a) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - end subroutine psb_c_transc_1mat - end interface - - interface - subroutine psb_c_transc_2mat(a,b) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(in) :: a - class(psb_cspmat_type), intent(inout) :: b - end subroutine psb_c_transc_2mat - end interface - - interface - subroutine psb_c_reinit(a,clear) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_c_reinit - - end interface - - - ! - ! These methods are specific to the outer SPMAT_TYPE level, since - ! they tamper with the inner BASE_SPARSE_MAT object. - ! - ! - - ! - ! CSCNV: switches to a different internal derived type. - ! 3 versions: copying to target - ! copying to a base_sparse_mat object. - ! in place - ! - ! - interface - subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(in) :: a - class(psb_cspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_c_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_c_cscnv - end interface - - - interface - subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(out) :: iinfo - integer(psb_ipk_),optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_c_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_c_cscnv_ip - end interface - - - interface - subroutine psb_c_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl - end subroutine psb_c_cscnv_base - end interface - - ! - ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. - ! - interface - subroutine psb_c_clip_d(a,b,info) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(in) :: a - class(psb_cspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - end subroutine psb_c_clip_d - end interface - - interface - subroutine psb_c_clip_d_ip(a,info) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info - end subroutine psb_c_clip_d_ip - end interface - - ! - ! These four interfaces cut through the - ! encapsulation between spmat_type and base_sparse_mat. - ! - interface - subroutine psb_c_mv_from(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - end subroutine psb_c_mv_from - end interface - - interface - subroutine psb_c_cp_from(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(out) :: a - class(psb_c_base_sparse_mat), intent(in) :: b - end subroutine psb_c_cp_from - end interface - - interface - subroutine psb_c_mv_to(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(inout) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - end subroutine psb_c_mv_to - end interface - - interface - subroutine psb_c_cp_to(a,b) - import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat - class(psb_cspmat_type), intent(in) :: a - class(psb_c_base_sparse_mat), intent(inout) :: b - end subroutine psb_c_cp_to - end interface - - ! - ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc - subroutine psb_cspmat_type_move(a,b,info) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - class(psb_cspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_cspmat_type_move - end interface - - interface - subroutine psb_cspmat_clone(a,b,info) - import :: psb_ipk_, psb_cspmat_type - class(psb_cspmat_type), intent(inout) :: a - class(psb_cspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_cspmat_clone - end interface - - - - - ! == =================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - ! == =================================== - - interface psb_csmm - subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_c_csmm - subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_c_csmv - subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans) - use psb_c_vect_mod, only : psb_c_vect_type - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta - type(psb_c_vect_type), intent(inout) :: x - type(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_c_csmv_vect - end interface - - interface psb_cssm - subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - end subroutine psb_c_cssm - subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta, x(:) - complex(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_spk_), intent(in), optional :: d(:) - end subroutine psb_c_cssv - subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) - use psb_c_vect_mod, only : psb_c_vect_type - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), intent(in) :: alpha, beta - type(psb_c_vect_type), intent(inout) :: x - type(psb_c_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - type(psb_c_vect_type), optional, intent(inout) :: d - end subroutine psb_c_cssv_vect - end interface - - interface - function psb_c_maxval(a) result(res) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - real(psb_spk_) :: res - end function psb_c_maxval - end interface - - interface - function psb_c_csnmi(a) result(res) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - real(psb_spk_) :: res - end function psb_c_csnmi - end interface - - interface - function psb_c_csnm1(a) result(res) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - real(psb_spk_) :: res - end function psb_c_csnm1 - end interface - - interface - function psb_c_rowsum(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_c_rowsum - end interface - - interface - function psb_c_arwsum(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_c_arwsum - end interface - - interface - function psb_c_colsum(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_c_colsum - end interface - - interface - function psb_c_aclsum(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_c_aclsum - end interface - - interface - function psb_c_get_diag(a,info) result(d) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_c_get_diag - end interface - - interface psb_scal - subroutine psb_c_scal(d,a,info,side) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(inout) :: a - complex(psb_spk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_c_scal - subroutine psb_c_scals(d,a,info) - import :: psb_ipk_, psb_cspmat_type, psb_spk_ - class(psb_cspmat_type), intent(inout) :: a - complex(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_c_scals - end interface - - -contains - - - - subroutine psb_c_set_mat_default(a) - implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - - if (allocated(psb_c_base_mat_default)) then - deallocate(psb_c_base_mat_default) - end if - allocate(psb_c_base_mat_default, mold=a) - - end subroutine psb_c_set_mat_default - - function psb_c_get_mat_default(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - class(psb_c_base_sparse_mat), pointer :: res - - res => psb_c_get_base_mat_default() - - end function psb_c_get_mat_default - - - function psb_c_get_base_mat_default() result(res) - implicit none - class(psb_c_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_c_base_mat_default)) then - allocate(psb_c_csr_sparse_mat :: psb_c_base_mat_default) - end if - - res => psb_c_base_mat_default - - end function psb_c_get_base_mat_default - - - - - ! == =================================== - ! - ! - ! - ! Getters - ! - ! - ! - ! - ! - ! == =================================== - - - function psb_c_sizeof(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - integer(psb_long_int_k_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_c_sizeof - - - function psb_c_get_fmt(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - character(len=5) :: res - - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' - end if - - end function psb_c_get_fmt - - - function psb_c_get_dupl(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_dupl() - else - res = psb_invalid_ - end if - end function psb_c_get_dupl - - function psb_c_get_nrows(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_nrows() - else - res = 0 - end if - - end function psb_c_get_nrows - - function psb_c_get_ncols(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_ncols() - else - res = 0 - end if - - end function psb_c_get_ncols - - function psb_c_is_triangle(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_triangle() - else - res = .false. - end if - - end function psb_c_is_triangle - - function psb_c_is_unit(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_unit() - else - res = .false. - end if - - end function psb_c_is_unit - - function psb_c_is_upper(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upper() - else - res = .false. - end if - - end function psb_c_is_upper - - function psb_c_is_lower(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = .not. a%a%is_upper() - else - res = .false. - end if - - end function psb_c_is_lower - - function psb_c_is_null(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_null() - else - res = .true. - end if - - end function psb_c_is_null - - function psb_c_is_bld(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_bld() - else - res = .false. - end if - - end function psb_c_is_bld - - function psb_c_is_upd(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upd() - else - res = .false. - end if - - end function psb_c_is_upd - - function psb_c_is_asb(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_asb() - else - res = .false. - end if - - end function psb_c_is_asb - - function psb_c_is_sorted(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_sorted() - else - res = .false. - end if - - end function psb_c_is_sorted - - function psb_c_is_by_rows(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_rows() - else - res = .false. - end if - - end function psb_c_is_by_rows - - function psb_c_is_by_cols(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_cols() - else - res = .false. - end if - - end function psb_c_is_by_cols - - - ! - subroutine c_mat_sync(a) - implicit none - class(psb_cspmat_type), target, intent(in) :: a - - if (allocated(a%a)) call a%a%sync() - - end subroutine c_mat_sync - - ! - subroutine c_mat_set_host(a) - implicit none - class(psb_cspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_host() - - end subroutine c_mat_set_host - - - ! - subroutine c_mat_set_dev(a) - implicit none - class(psb_cspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_dev() - - end subroutine c_mat_set_dev - - ! - subroutine c_mat_set_sync(a) - implicit none - class(psb_cspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_sync() - - end subroutine c_mat_set_sync - - ! - function c_mat_is_dev(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_dev() - else - res = .false. - end if - end function c_mat_is_dev - - ! - function c_mat_is_host(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_host() - else - res = .true. - end if - end function c_mat_is_host - - ! - function c_mat_is_sync(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_sync() - else - res = .true. - end if - - end function c_mat_is_sync - - - function psb_c_is_repeatable_updates(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_repeatable_updates() - else - res = .false. - end if - - end function psb_c_is_repeatable_updates - - subroutine psb_c_set_repeatable_updates(a,val) - implicit none - class(psb_cspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - - if (allocated(a%a)) then - call a%a%set_repeatable_updates(val) - end if - - end subroutine psb_c_set_repeatable_updates - - - function psb_c_get_nzeros(a) result(res) - implicit none - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%get_nzeros() - end if - - end function psb_c_get_nzeros - - function psb_c_get_size(a) result(res) - - implicit none - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - - res = 0 - if (allocated(a%a)) then - res = a%a%get_size() - end if - - end function psb_c_get_size - - - function psb_c_get_nz_row(idx,a) result(res) - implicit none - integer(psb_ipk_), intent(in) :: idx - class(psb_cspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - - if (allocated(a%a)) res = a%a%get_nz_row(idx) - - end function psb_c_get_nz_row - - subroutine psb_c_clean_zeros(a,info) - implicit none - integer(psb_ipk_), intent(out) :: info - class(psb_cspmat_type), intent(inout) :: a - - info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) - - end subroutine psb_c_clean_zeros - - -end module psb_c_mat_mod diff --git a/base/modules/serial/psb_c_serial_mod.f90 b/base/modules/serial/psb_c_serial_mod.f90 index 1aef3e846..b3e3abd09 100644 --- a/base/modules/serial/psb_c_serial_mod.f90 +++ b/base/modules/serial/psb_c_serial_mod.f90 @@ -119,9 +119,9 @@ module psb_c_serial_mod use psb_c_mat_mod, only : psb_cspmat_type import :: psb_ipk_ implicit none - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr type(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info type(psb_cspmat_type), intent(in), optional :: b logical,intent(in), optional :: rowscale end subroutine psb_crwextd @@ -129,12 +129,32 @@ module psb_c_serial_mod use psb_c_mat_mod, only : psb_c_base_sparse_mat import :: psb_ipk_ implicit none - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr class(psb_c_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: b logical,intent(in), optional :: rowscale end subroutine psb_cbase_rwextd + subroutine psb_lcrwextd(nr,a,info,b,rowscale) + use psb_c_mat_mod, only : psb_lcspmat_type + import :: psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: nr + type(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + type(psb_lcspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + end subroutine psb_lcrwextd + subroutine psb_lcbase_rwextd(nr,a,info,b,rowscale) + use psb_c_mat_mod, only : psb_lc_base_sparse_mat + import :: psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: nr + class(psb_lc_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + class(psb_lc_base_sparse_mat), intent(in), optional :: b + logical,intent(in), optional :: rowscale + end subroutine psb_lcbase_rwextd end interface psb_rwextd @@ -203,6 +223,69 @@ module psb_c_serial_mod end subroutine psb_c_aspxpby end interface psb_aspxpby + interface psb_spspmm + subroutine psb_lcspspmm(a,b,c,info) + use psb_c_mat_mod, only : psb_lcspmat_type + import :: psb_ipk_ + implicit none + type(psb_lcspmat_type), intent(in) :: a,b + type(psb_lcspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lcspspmm + subroutine psb_lccsrspspmm(a,b,c,info) + use psb_c_mat_mod, only : psb_lc_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lccsrspspmm + subroutine psb_lccscspspmm(a,b,c,info) + use psb_c_mat_mod, only : psb_lc_csc_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a,b + type(psb_lc_csc_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lccscspspmm + end interface psb_spspmm + + interface psb_symbmm + subroutine psb_lcsymbmm(a,b,c,info) + use psb_c_mat_mod, only : psb_lcspmat_type + import :: psb_ipk_ + implicit none + type(psb_lcspmat_type), intent(in) :: a,b + type(psb_lcspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lcsymbmm + subroutine psb_lcbase_symbmm(a,b,c,info) + use psb_c_mat_mod, only : psb_lc_base_sparse_mat, psb_lc_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lcbase_symbmm + end interface psb_symbmm + + interface psb_numbmm + subroutine psb_lcnumbmm(a,b,c) + use psb_c_mat_mod, only : psb_lcspmat_type + import :: psb_ipk_ + implicit none + type(psb_lcspmat_type), intent(in) :: a,b + type(psb_lcspmat_type), intent(inout) :: c + end subroutine psb_lcnumbmm + subroutine psb_lcbase_numbmm(a,b,c) + use psb_c_mat_mod, only : psb_lc_base_sparse_mat, psb_lc_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(inout) :: c + end subroutine psb_lcbase_numbmm + end interface psb_numbmm + contains subroutine psb_ccsprt(iout,a,iv,head,ivr,ivc) diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index 20d7e3c04..c7a9a0742 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -62,8 +62,9 @@ module psb_c_vect_mod procedure, pass(x) :: ins_v => c_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => c_vect_bld_x - procedure, pass(x) :: bld_n => c_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => c_vect_bld_mn + procedure, pass(x) :: bld_en => c_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => c_vect_get_vect procedure, pass(x) :: cnv => c_vect_cnv procedure, pass(x) :: set_scal => c_vect_set_scal @@ -112,7 +113,8 @@ module psb_c_vect_mod & c_vect_all, c_vect_reall, c_vect_zero, c_vect_asb, & & c_vect_gthab, c_vect_gthzv, c_vect_sctb, & & c_vect_free, c_vect_ins_a, c_vect_ins_v, c_vect_bld_x, & - & c_vect_bld_n, c_vect_get_vect, c_vect_cnv, c_vect_set_scal, & + & c_vect_bld_mn, c_vect_bld_en, c_vect_get_vect, & + & c_vect_cnv, c_vect_set_scal, & & c_vect_set_vect, c_vect_clone, c_vect_sync, c_vect_is_host, & & c_vect_is_dev, c_vect_is_sync, c_vect_set_host, & & c_vect_set_dev, c_vect_set_sync @@ -207,8 +209,8 @@ contains end subroutine c_vect_bld_x - subroutine c_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine c_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_c_vect_type), intent(inout) :: x class(psb_c_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -225,7 +227,28 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine c_vect_bld_n + end subroutine c_vect_bld_mn + + + subroutine c_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_c_vect_type), intent(inout) :: x + class(psb_c_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + + info = psb_success_ + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_c_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine c_vect_bld_en function c_vect_get_vect(x,n) result(res) class(psb_c_vect_type), intent(inout) :: x @@ -291,7 +314,7 @@ contains function c_vect_sizeof(x) result(res) implicit none class(psb_c_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function c_vect_sizeof @@ -1014,7 +1037,7 @@ contains function c_vect_sizeof(x) result(res) implicit none class(psb_c_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function c_vect_sizeof diff --git a/base/modules/serial/psb_d_base_mat_mod.f90 b/base/modules/serial/psb_d_base_mat_mod.f90 index 8d04f5b7c..19bc1d6f1 100644 --- a/base/modules/serial/psb_d_base_mat_mod.f90 +++ b/base/modules/serial/psb_d_base_mat_mod.f90 @@ -79,6 +79,18 @@ module psb_d_base_mat_mod procedure, pass(a) :: clone => psb_d_base_clone procedure, pass(a) :: make_nonunit => psb_d_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_d_base_clean_zeros + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_lcoo => psb_d_base_cp_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_d_base_cp_from_lcoo + procedure, pass(a) :: cp_to_lfmt => psb_d_base_cp_to_lfmt + procedure, pass(a) :: cp_from_lfmt => psb_d_base_cp_from_lfmt + procedure, pass(a) :: mv_to_lcoo => psb_d_base_mv_to_lcoo + procedure, pass(a) :: mv_from_lcoo => psb_d_base_mv_from_lcoo + procedure, pass(a) :: mv_to_lfmt => psb_d_base_mv_to_lfmt + procedure, pass(a) :: mv_from_lfmt => psb_d_base_mv_from_lfmt + ! ! Transpose methods: defined here but not implemented. @@ -115,7 +127,10 @@ module psb_d_base_mat_mod procedure, pass(a) :: aclsum => psb_d_base_aclsum end type psb_d_base_sparse_mat - + private :: d_base_mat_sync, d_base_mat_is_host, d_base_mat_is_dev, & + & d_base_mat_is_sync, d_base_mat_set_host, d_base_mat_set_dev,& + & d_base_mat_set_sync + !> \namespace psb_base_mod \class psb_d_coo_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat !! @@ -155,6 +170,13 @@ module psb_d_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_d_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_d_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_d_mv_coo_from_fmt + + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_lcoo => psb_d_cp_coo_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_d_cp_coo_from_lcoo + procedure, pass(a) :: csput_a => psb_d_coo_csput_a procedure, pass(a) :: get_diag => psb_d_coo_get_diag procedure, pass(a) :: csgetrow => psb_d_coo_csgetrow @@ -212,6 +234,183 @@ module psb_d_base_mat_mod & d_coo_transp_1mat, d_coo_transc_1mat + !> \namespace psb_base_mod \class psb_ld_base_sparse_mat + !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat + !! The psb_ld_base_sparse_mat type, extending psb_base_sparse_mat, + !! defines a middle level real(psb_dpk_) sparse matrix object. + !! This class object itself does not have any additional members + !! with respect to those of the base class. Most methods cannot be fully + !! implemented at this level, but we can define the interface for the + !! computational methods requiring the knowledge of the underlying + !! field, such as the matrix-vector product; this interface is defined, + !! but is supposed to be overridden at the leaf level. + !! + !! About the method MOLD: this has been defined for those compilers + !! not yet supporting ALLOCATE( ...,MOLD=...); it's otherwise silly to + !! duplicate "by hand" what is specified in the language (in this case F2008) + !! + type, extends(psb_lbase_sparse_mat) :: psb_ld_base_sparse_mat + contains + ! + ! Data management methods: defined here, but (mostly) not implemented. + ! + procedure, pass(a) :: csput_a => psb_ld_base_csput_a + procedure, pass(a) :: csput_v => psb_ld_base_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetrow => psb_ld_base_csgetrow + procedure, pass(a) :: csgetblk => psb_ld_base_csgetblk + procedure, pass(a) :: get_diag => psb_ld_base_get_diag + generic, public :: csget => csgetrow, csgetblk + procedure, pass(a) :: tril => psb_ld_base_tril + procedure, pass(a) :: triu => psb_ld_base_triu + procedure, pass(a) :: csclip => psb_ld_base_csclip + procedure, pass(a) :: cp_to_coo => psb_ld_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_ld_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ld_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ld_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ld_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_ld_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ld_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ld_base_mv_from_fmt + procedure, pass(a) :: mold => psb_ld_base_mold + procedure, pass(a) :: clone => psb_ld_base_clone + procedure, pass(a) :: make_nonunit => psb_ld_base_make_nonunit + procedure, pass(a) :: clean_zeros => psb_ld_base_clean_zeros + + ! + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_ld_base_scals + procedure, pass(a) :: scalv => psb_ld_base_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: maxval => psb_ld_base_maxval + procedure, pass(a) :: spnmi => psb_ld_base_csnmi + procedure, pass(a) :: spnm1 => psb_ld_base_csnm1 + procedure, pass(a) :: rowsum => psb_ld_base_rowsum + procedure, pass(a) :: arwsum => psb_ld_base_arwsum + procedure, pass(a) :: colsum => psb_ld_base_colsum + procedure, pass(a) :: aclsum => psb_ld_base_aclsum + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_icoo => psb_ld_base_cp_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_ld_base_cp_from_icoo + procedure, pass(a) :: cp_to_ifmt => psb_ld_base_cp_to_ifmt + procedure, pass(a) :: cp_from_ifmt => psb_ld_base_cp_from_ifmt + procedure, pass(a) :: mv_to_icoo => psb_ld_base_mv_to_icoo + procedure, pass(a) :: mv_from_icoo => psb_ld_base_mv_from_icoo + procedure, pass(a) :: mv_to_ifmt => psb_ld_base_mv_to_ifmt + procedure, pass(a) :: mv_from_ifmt => psb_ld_base_mv_from_ifmt + + ! + ! Transpose methods: defined here but not implemented. + ! + procedure, pass(a) :: transp_1mat => psb_ld_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_ld_base_transp_2mat + procedure, pass(a) :: transc_1mat => psb_ld_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_ld_base_transc_2mat + + end type psb_ld_base_sparse_mat + + private :: ld_base_mat_sync, ld_base_mat_is_host, ld_base_mat_is_dev, & + & ld_base_mat_is_sync, ld_base_mat_set_host, ld_base_mat_set_dev,& + & ld_base_mat_set_sync + + !> \namespace psb_base_mod \class psb_ld_coo_sparse_mat + !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat + !! + !! psb_ld_coo_sparse_mat type and the related methods. This is the + !! reference type for all the format transitions, copies and mv unless + !! methods are implemented that allow the direct transition from one + !! format to another. It is defined here since all other classes must + !! refer to it per the MEDIATOR design pattern. + !! + type, extends(psb_ld_base_sparse_mat) :: psb_ld_coo_sparse_mat + !> Number of nonzeros. + integer(psb_lpk_) :: nnz + !> Row indices. + integer(psb_lpk_), allocatable :: ia(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + real(psb_dpk_), allocatable :: val(:) + + integer, private :: sort_status=psb_unsorted_ + + contains + ! + ! Data management methods. + ! + procedure, pass(a) :: get_size => ld_coo_get_size + procedure, pass(a) :: get_nzeros => ld_coo_get_nzeros + procedure, nopass :: get_fmt => ld_coo_get_fmt + procedure, pass(a) :: sizeof => ld_coo_sizeof + procedure, pass(a) :: reallocate_nz => psb_ld_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_ld_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_ld_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => psb_ld_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ld_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ld_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ld_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => psb_ld_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ld_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ld_mv_coo_from_fmt + procedure, pass(a) :: cp_to_icoo => psb_ld_cp_coo_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_ld_cp_coo_from_icoo + + procedure, pass(a) :: csput_a => psb_ld_coo_csput_a + procedure, pass(a) :: get_diag => psb_ld_coo_get_diag + procedure, pass(a) :: csgetrow => psb_ld_coo_csgetrow + procedure, pass(a) :: csgetptn => psb_ld_coo_csgetptn + procedure, pass(a) :: reinit => psb_ld_coo_reinit + procedure, pass(a) :: get_nz_row => psb_ld_coo_get_nz_row + procedure, pass(a) :: fix => psb_ld_fix_coo + procedure, pass(a) :: trim => psb_ld_coo_trim + procedure, pass(a) :: clean_zeros => psb_ld_coo_clean_zeros + procedure, pass(a) :: print => psb_ld_coo_print + procedure, pass(a) :: free => ld_coo_free + procedure, pass(a) :: mold => psb_ld_coo_mold + procedure, pass(a) :: is_sorted => ld_coo_is_sorted + procedure, pass(a) :: is_by_rows => ld_coo_is_by_rows + procedure, pass(a) :: is_by_cols => ld_coo_is_by_cols + procedure, pass(a) :: set_by_rows => ld_coo_set_by_rows + procedure, pass(a) :: set_by_cols => ld_coo_set_by_cols + procedure, pass(a) :: set_sort_status => ld_coo_set_sort_status + procedure, pass(a) :: get_sort_status => ld_coo_get_sort_status + + + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_ld_coo_scals + procedure, pass(a) :: scalv => psb_ld_coo_scal + procedure, pass(a) :: maxval => psb_ld_coo_maxval + procedure, pass(a) :: spnmi => psb_ld_coo_csnmi + procedure, pass(a) :: spnm1 => psb_ld_coo_csnm1 + procedure, pass(a) :: rowsum => psb_ld_coo_rowsum + procedure, pass(a) :: arwsum => psb_ld_coo_arwsum + procedure, pass(a) :: colsum => psb_ld_coo_colsum + procedure, pass(a) :: aclsum => psb_ld_coo_aclsum + + ! + ! This is COO specific + ! + procedure, pass(a) :: set_nzeros => ld_coo_set_nzeros + + ! + ! Transpose methods. These are the base of all + ! indirection in transpose, together with conversions + ! they are sufficient for all cases. + ! + procedure, pass(a) :: transp_1mat => ld_coo_transp_1mat + procedure, pass(a) :: transc_1mat => ld_coo_transc_1mat + + + end type psb_ld_coo_sparse_mat + + private :: ld_coo_get_nzeros, ld_coo_set_nzeros, & + & ld_coo_get_fmt, ld_coo_free, ld_coo_sizeof, & + & ld_coo_transp_1mat, ld_coo_transc_1mat + ! == ================= ! @@ -257,7 +456,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -268,8 +467,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_, psb_d_base_vect_type,& - & psb_i_base_vect_type + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -314,7 +512,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -324,7 +522,7 @@ module psb_d_base_mat_mod logical, intent(in), optional :: append integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale, chksz + logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_d_base_csgetrow end interface @@ -353,7 +551,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -391,7 +589,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -432,7 +630,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -476,7 +674,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -499,7 +697,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_get_diag(a,d,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -518,7 +716,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_mold(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_long_int_k_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -540,7 +738,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_clone(a,b, info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_long_int_k_ + import implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), allocatable, intent(inout) :: b @@ -559,7 +757,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_make_nonunit(a) - import :: psb_d_base_sparse_mat + import implicit none class(psb_d_base_sparse_mat), intent(inout) :: a end subroutine psb_d_base_make_nonunit @@ -576,7 +774,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_cp_to_coo(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -593,7 +791,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_cp_from_coo(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -611,7 +809,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_cp_to_fmt(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -629,7 +827,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_cp_from_fmt(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -646,7 +844,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_mv_to_coo(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -663,7 +861,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_mv_from_coo(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -681,7 +879,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_mv_to_fmt(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -699,12 +897,153 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_mv_from_fmt(a,b,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_mv_from_fmt end interface + ! + !> Function cp_to_coo: + !! \memberof psb_d_base_sparse_mat + !! \brief Copy and convert to psb_d_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_d_base_cp_to_lcoo(a,b,info) + import + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_cp_to_lcoo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_d_base_sparse_mat + !! \brief Copy and convert from psb_d_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_d_base_cp_from_lcoo(a,b,info) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_cp_from_lcoo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_d_base_sparse_mat + !! \brief Copy and convert to a class(psb_d_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_d_base_cp_to_lfmt(a,b,info) + import + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_cp_to_lfmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_d_base_sparse_mat + !! \brief Copy and convert from a class(psb_d_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_d_base_cp_from_lfmt(a,b,info) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_cp_from_lfmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_d_base_sparse_mat + !! \brief Convert to psb_d_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_d_base_mv_to_lcoo(a,b,info) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_mv_to_lcoo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_d_base_sparse_mat + !! \brief Convert from psb_d_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_d_base_mv_from_lcoo(a,b,info) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_mv_from_lcoo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_d_base_sparse_mat + !! \brief Convert to a class(psb_d_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_d_base_mv_to_lfmt(a,b,info) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_mv_to_lfmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_d_base_sparse_mat + !! \brief Convert from a class(psb_d_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_d_base_mv_from_lfmt(a,b,info) + import + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_mv_from_lfmt + end interface + + ! !> !! \memberof psb_d_base_sparse_mat @@ -712,7 +1051,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_clean_zeros(a, info) - import :: psb_ipk_, psb_d_base_sparse_mat + import class(psb_d_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_clean_zeros @@ -728,7 +1067,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_transp_2mat(a,b) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_d_base_transp_2mat @@ -744,7 +1083,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_transc_2mat(a,b) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_d_base_transc_2mat @@ -759,7 +1098,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_transp_1mat(a) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a end subroutine psb_d_base_transp_1mat end interface @@ -773,7 +1112,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_transc_1mat(a) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a end subroutine psb_d_base_transc_1mat end interface @@ -798,7 +1137,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -826,7 +1165,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -861,7 +1200,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_vect_mv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_, psb_d_base_vect_type + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x @@ -893,7 +1232,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -928,7 +1267,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -963,7 +1302,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_, psb_d_base_vect_type + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x, y @@ -995,7 +1334,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1028,7 +1367,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1062,7 +1401,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_,psb_d_base_vect_type + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta class(psb_d_base_vect_type), intent(inout) :: x,y @@ -1082,7 +1421,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_scals(d,a,info) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1100,7 +1439,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_scal(d,a,info,side) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1116,7 +1455,7 @@ module psb_d_base_mat_mod ! interface function psb_d_base_maxval(a) result(res) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_base_maxval @@ -1131,7 +1470,7 @@ module psb_d_base_mat_mod ! interface function psb_d_base_csnmi(a) result(res) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_base_csnmi @@ -1146,7 +1485,7 @@ module psb_d_base_mat_mod ! interface function psb_d_base_csnm1(a) result(res) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_base_csnm1 @@ -1162,7 +1501,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_rowsum(d,a) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_base_rowsum @@ -1176,7 +1515,7 @@ module psb_d_base_mat_mod !! interface subroutine psb_d_base_arwsum(d,a) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_base_arwsum @@ -1192,7 +1531,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_base_colsum(d,a) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_base_colsum @@ -1206,7 +1545,7 @@ module psb_d_base_mat_mod !! interface subroutine psb_d_base_aclsum(d,a) - import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_ + import class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_base_aclsum @@ -1226,7 +1565,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_coo_reallocate_nz(nz,a) - import :: psb_ipk_, psb_d_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_d_coo_sparse_mat), intent(inout) :: a end subroutine psb_d_coo_reallocate_nz @@ -1239,7 +1578,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_coo_reinit(a,clear) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_d_coo_reinit @@ -1251,7 +1590,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_coo_trim(a) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a end subroutine psb_d_coo_trim end interface @@ -1262,7 +1601,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_coo_clean_zeros(a,info) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_clean_zeros @@ -1275,7 +1614,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_d_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -1287,7 +1626,7 @@ module psb_d_base_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_d_coo_mold(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ + import class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -1309,7 +1648,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_d_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -1330,7 +1669,7 @@ module psb_d_base_mat_mod ! interface function psb_d_coo_get_nz_row(idx,a) result(res) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res @@ -1354,11 +1693,12 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import :: psb_ipk_, psb_dpk_ + import integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) real(psb_dpk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout, info + integer(psb_ipk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_d_fix_coo_inner end interface @@ -1373,7 +1713,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_fix_coo(a,info,idir) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir @@ -1385,7 +1725,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_to_coo interface subroutine psb_d_cp_coo_to_coo(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1397,12 +1737,35 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo interface subroutine psb_d_cp_coo_from_coo(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_d_cp_coo_from_coo end interface + !> + !! \memberof psb_d_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_d_base_cp_to_coo + interface + subroutine psb_d_cp_coo_to_lcoo(a,b,info) + import + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_cp_coo_to_lcoo + end interface + + !> + !! \memberof psb_d_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo + interface + subroutine psb_d_cp_coo_from_lcoo(a,b,info) + import + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_cp_coo_from_lcoo + end interface !> !! \memberof psb_d_coo_sparse_mat @@ -1410,7 +1773,7 @@ module psb_d_base_mat_mod !! interface subroutine psb_d_cp_coo_to_fmt(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1423,7 +1786,7 @@ module psb_d_base_mat_mod !! interface subroutine psb_d_cp_coo_from_fmt(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -1435,7 +1798,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_to_coo interface subroutine psb_d_mv_coo_to_coo(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1447,7 +1810,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_from_coo interface subroutine psb_d_mv_coo_from_coo(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1459,7 +1822,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_to_fmt interface subroutine psb_d_mv_coo_to_fmt(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1471,7 +1834,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_from_fmt interface subroutine psb_d_mv_coo_from_fmt(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_coo_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1480,7 +1843,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_coo_cp_from(a,b) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(inout) :: a type(psb_d_coo_sparse_mat), intent(in) :: b end subroutine psb_d_coo_cp_from @@ -1488,7 +1851,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_coo_mv_from(a,b) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(inout) :: a type(psb_d_coo_sparse_mat), intent(inout) :: b end subroutine psb_d_coo_mv_from @@ -1513,7 +1876,7 @@ module psb_d_base_mat_mod ! interface subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -1529,7 +1892,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1548,7 +1911,7 @@ module psb_d_base_mat_mod interface subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1567,7 +1930,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cssv interface subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1580,7 +1943,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cssm interface subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1594,7 +1957,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csmv interface subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -1608,7 +1971,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csmm interface subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -1623,7 +1986,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_maxval interface function psb_d_coo_maxval(a) result(res) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_coo_maxval @@ -1634,7 +1997,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csnmi interface function psb_d_coo_csnmi(a) result(res) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_coo_csnmi @@ -1645,7 +2008,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csnm1 interface function psb_d_coo_csnm1(a) result(res) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_coo_csnm1 @@ -1656,7 +2019,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_rowsum interface subroutine psb_d_coo_rowsum(d,a) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_coo_rowsum @@ -1666,7 +2029,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_arwsum interface subroutine psb_d_coo_arwsum(d,a) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_coo_arwsum @@ -1677,7 +2040,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_colsum interface subroutine psb_d_coo_colsum(d,a) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_coo_colsum @@ -1688,7 +2051,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_aclsum interface subroutine psb_d_coo_aclsum(d,a) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_coo_aclsum @@ -1699,7 +2062,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_get_diag interface subroutine psb_d_coo_get_diag(a,d,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1711,7 +2074,7 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_scal interface subroutine psb_d_coo_scal(d,a,info,side) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1724,13 +2087,1351 @@ module psb_d_base_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_scals interface subroutine psb_d_coo_scals(d,a,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_coo_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_scals end interface + ! == ================= + ! + ! BASE interfaces + ! + ! == ================= + + !> Function csput: + !! \memberof psb_ld_base_sparse_mat + !! \brief Insert coefficients. + !! + !! + !! Given a list of NZ triples + !! (IA(i),JA(i),VAL(i)) + !! record a new coefficient in A such that + !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). + !! + !! The internal components IA,JA,VAL are reallocated as necessary. + !! Constraints: + !! - If the matrix A is in the BUILD state, then the method will + !! only work for COO matrices, all other format will throw an error. + !! In this case coefficients are queued inside A for further processing. + !! - If the matrix A is in the UPDATE state, then it can be in any format; + !! the update operation will perform either + !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ) + !! or + !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) + !! according to the value of DUPLICATE. + !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! + !! \param nz number of triples in input + !! \param ia(:) the input row indices + !! \param ja(:) the input col indices + !! \param val(:) the input coefficients + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index + !! \param info return code + !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) + !! + ! + interface + subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_base_csput_a + end interface + + interface + subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_base_csput_v + end interface + + ! + ! + !> Function csgetrow: + !! \memberof psb_ld_base_sparse_mat + !! \brief Get a (subset of) row(s) + !! + !! getrow is the basic method by which the other (getblk, clip) can + !! be implemented. + !! + !! Returns the set + !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) + !! each identifying the position of a nonzero in A + !! between row indices IMIN:IMAX; + !! IA,JA are reallocated as necessary. + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param nz the number of output coefficients + !! \param ia(:) the output row indices + !! \param ja(:) the output col indices + !! \param val(:) the output coefficients + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_ld_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_base_csgetrow + end interface + + ! + !> Function csgetblk: + !! \memberof psb_ld_base_sparse_mat + !! \brief Get a (subset of) row(s) + !! + !! getblk is very similar to getrow, except that the output + !! is packaged in a psb_ld_coo_sparse_mat object + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param b the output (sub)matrix + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_base_csgetblk + end interface + + ! + ! + !> Function csclip: + !! \memberof psb_ld_base_sparse_mat + !! \brief Get a submatrix. + !! + !! csclip is practically identical to getblk. + !! One of them has to go away..... + !! + !! \param b the output submatrix + !! \param info return code + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_ld_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_base_csclip + end interface + ! + !> Function tril: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_ld_base_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_ld_base_tril + end interface + + ! + !> Function triu: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_ld_base_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_ld_base_triu + end interface + + + ! + !> Function get_diag: + !! \memberof psb_ld_base_sparse_mat + !! \brief Extract the diagonal of A. + !! + !! D(i) = A(i:i), i=1:min(nrows,ncols) + !! + !! \param d(:) The output diagonal + !! \param info return code. + ! + interface + subroutine psb_ld_base_get_diag(a,d,info) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_get_diag + end interface + + ! + !> Function mold: + !! \memberof psb_ld_base_sparse_mat + !! \brief Allocate a class(psb_ld_base_sparse_mat) with the + !! same dynamic type as the input. + !! This is equivalent to allocate( mold= ) and is provided + !! for those compilers not yet supporting mold. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mold(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mold + end interface + + ! + ! + !> Function clone: + !! \memberof psb_ld_base_sparse_mat + !! \brief Allocate and clone a class(psb_ld_base_sparse_mat) with the + !! same dynamic type as the input. + !! This is equivalent to allocate( source= ) except that + !! it should guarantee a deep copy wherever needed. + !! Should also be equivalent to calling mold and then copy, + !! but it can also be implemented by default using cp_to_fmt. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_clone(a,b, info) + import + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_clone + end interface + + + ! + ! + !> Function make_nonunit: + !! \memberof psb_ld_base_make_nonunit + !! \brief Given a matrix for which is_unit() is true, explicitly + !! store the unit diagonal and set is_unit() to false. + !! This is needed e.g. when scaling + ! + interface + subroutine psb_ld_base_make_nonunit(a) + import + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + end subroutine psb_ld_base_make_nonunit + end interface + + + ! + !> Function cp_to_coo: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy and convert to psb_ld_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_cp_to_coo(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_cp_to_coo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy and convert from psb_ld_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_ld_base_cp_from_coo(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_cp_from_coo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy and convert to a class(psb_ld_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_cp_to_fmt(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_cp_to_fmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy and convert from a class(psb_ld_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_cp_from_fmt(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_cp_from_fmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_ld_base_sparse_mat + !! \brief Convert to psb_ld_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mv_to_coo(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mv_to_coo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_ld_base_sparse_mat + !! \brief Convert from psb_ld_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mv_from_coo(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mv_from_coo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_ld_base_sparse_mat + !! \brief Convert to a class(psb_ld_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mv_to_fmt(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mv_to_fmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_ld_base_sparse_mat + !! \brief Convert from a class(psb_ld_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mv_from_fmt(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mv_from_fmt + end interface + + + ! + !> Function cp_to_coo: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy and convert to psb_ld_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_cp_to_icoo(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_cp_to_icoo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy and convert from psb_ld_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_ld_base_cp_from_icoo(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_cp_from_icoo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy and convert to a class(psb_ld_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_cp_to_ifmt(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_cp_to_ifmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_ld_base_sparse_mat + !! \brief Copy and convert from a class(psb_ld_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_cp_from_ifmt(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_cp_from_ifmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_ld_base_sparse_mat + !! \brief Convert to psb_ld_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mv_to_icoo(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mv_to_icoo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_ld_base_sparse_mat + !! \brief Convert from psb_ld_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mv_from_icoo(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mv_from_icoo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_ld_base_sparse_mat + !! \brief Convert to a class(psb_ld_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mv_to_ifmt(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mv_to_ifmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_ld_base_sparse_mat + !! \brief Convert from a class(psb_ld_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ld_base_mv_from_ifmt(a,b,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_mv_from_ifmt + end interface + + + + ! + !> + !! \memberof psb_ld_base_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros + ! + interface + subroutine psb_ld_base_clean_zeros(a, info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_clean_zeros + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_maxval + interface + function psb_ld_coo_maxval(a) result(res) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_coo_maxval + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_csnmi + interface + function psb_ld_coo_csnmi(a) result(res) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_coo_csnmi + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_csnm1 + interface + function psb_ld_coo_csnm1(a) result(res) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_coo_csnm1 + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_rowsum + interface + subroutine psb_ld_coo_rowsum(d,a) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_coo_rowsum + end interface + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_arwsum + interface + subroutine psb_ld_coo_arwsum(d,a) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_coo_arwsum + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_colsum + interface + subroutine psb_ld_coo_colsum(d,a) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_coo_colsum + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_aclsum + interface + subroutine psb_ld_coo_aclsum(d,a) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_coo_aclsum + end interface + + ! + !> Function base_scals: + !! \memberof psb_ld_base_sparse_mat + !! \brief Scale a matrix by a single scalar value + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_ld_base_scals(d,a,info) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_base_scals + end interface + + ! + !> Function base_scal: + !! \memberof psb_ld_base_sparse_mat + !! \brief Scale a matrix by a vector + !! + !! \param d(:) Scaling vector + !! \param info return code + !! \param side [L] Scale on the Left (rows) or on the Right (columns) + ! + interface + subroutine psb_ld_base_scal(d,a,info,side) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ld_base_scal + end interface + + ! + !> Function base_maxval: + !! \memberof psb_ld_base_sparse_mat + !! \brief Maximum absolute value of all coefficients; + !! + ! + interface + function psb_ld_base_maxval(a) result(res) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_base_maxval + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_ld_base_sparse_mat + !! \brief Operator infinity norm + !! + ! + interface + function psb_ld_base_csnmi(a) result(res) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_base_csnmi + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_ld_base_sparse_mat + !! \brief Operator 1-norm + !! + ! + interface + function psb_ld_base_csnm1(a) result(res) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_base_csnm1 + end interface + + ! + ! + !> Function base_rowsum: + !! \memberof psb_ld_base_sparse_mat + !! \brief Sum along the rows + !! \param d(:) The output row sums + !! + ! + interface + subroutine psb_ld_base_rowsum(d,a) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_base_rowsum + end interface + + ! + !> Function base_arwsum: + !! \memberof psb_ld_base_sparse_mat + !! \brief Absolute value sum along the rows + !! \param d(:) The output row sums + !! + interface + subroutine psb_ld_base_arwsum(d,a) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_base_arwsum + end interface + + ! + ! + !> Function base_colsum: + !! \memberof psb_ld_base_sparse_mat + !! \brief Sum along the columns + !! \param d(:) The output col sums + !! + ! + interface + subroutine psb_ld_base_colsum(d,a) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_base_colsum + end interface + + ! + !> Function base_aclsum: + !! \memberof psb_ld_base_sparse_mat + !! \brief Absolute value sum along the columns + !! \param d(:) The output col sums + !! + interface + subroutine psb_ld_base_aclsum(d,a) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_base_aclsum + end interface + + + ! + !> Function transp: + !! \memberof psb_ld_base_sparse_mat + !! \brief Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! Copyout version + !! \param b The output variable + ! + interface + subroutine psb_ld_base_transp_2mat(a,b) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + end subroutine psb_ld_base_transp_2mat + end interface + + ! + !> Function transc: + !! \memberof psb_ld_base_sparse_mat + !! \brief Conjugate Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! Copyout version. + !! \param b The output variable + ! + interface + subroutine psb_ld_base_transc_2mat(a,b) + import + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + end subroutine psb_ld_base_transc_2mat + end interface + + ! + !> Function transp: + !! \memberof psb_ld_base_sparse_mat + !! \brief Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! In-place version. + ! + interface + subroutine psb_ld_base_transp_1mat(a) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + end subroutine psb_ld_base_transp_1mat + end interface + + ! + !> Function transc: + !! \memberof psb_ld_base_sparse_mat + !! \brief Conjugate Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! In-place version. + ! + interface + subroutine psb_ld_base_transc_1mat(a) + import + class(psb_ld_base_sparse_mat), intent(inout) :: a + end subroutine psb_ld_base_transc_1mat + end interface + + ! == =============== + ! + ! COO interfaces + ! + ! == =============== + + ! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reallocate_nz + ! + interface + subroutine psb_ld_coo_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_coo_sparse_mat), intent(inout) :: a + end subroutine psb_ld_coo_reallocate_nz + end interface + + ! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reinit + ! + interface + subroutine psb_ld_coo_reinit(a,clear) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ld_coo_reinit + end interface + ! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_trim + ! + interface + subroutine psb_ld_coo_trim(a) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + end subroutine psb_ld_coo_trim + end interface + ! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_clean_zeros + ! + interface + subroutine psb_ld_coo_clean_zeros(a,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_coo_clean_zeros + end interface + + ! + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_allocate_mnnz + ! + interface + subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ld_coo_allocate_mnnz + end interface + + + !> \memberof psb_ld_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_ld_coo_mold(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_coo_mold + end interface + + + ! + !> Function print. + !! \memberof psb_ld_coo_sparse_mat + !! \brief Print the matrix to file in MatrixMarket format + !! + !! \param iout The unit to write to + !! \param iv [none] Renumbering for both rows and columns + !! \param head [none] Descriptive header for the file + !! \param ivr [none] Row renumbering + !! \param ivc [none] Col renumbering + !! + ! + interface + subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_coo_print + end interface + + + + ! + !> Function get_nz_row. + !! \memberof psb_ld_coo_sparse_mat + !! \brief How many nonzeros in a row? + !! + !! \param idx The row to search. + !! + ! + interface + function psb_ld_coo_get_nz_row(idx,a) result(res) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + end function psb_ld_coo_get_nz_row + end interface + + + ! + !> Funtion: fix_coo_inner + !! \brief Make sure the entries are sorted and duplicates are handled. + !! Used internally by fix_coo + !! \param nzin Number of entries on input to be handled + !! \param dupl What to do with duplicated entries. + !! \param ia(:) Row indices + !! \param ja(:) Col indices + !! \param val(:) Coefficients + !! \param nzout Number of entries after sorting/duplicate handling + !! \param info return code + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! + ! + interface + subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import + integer(psb_lpk_), intent(in) :: nr,nc,nzin + integer(psb_ipk_), intent(in) :: dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + real(psb_dpk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + end subroutine psb_ld_fix_coo_inner + end interface + + ! + !> Function fix_coo + !! \memberof psb_ld_coo_sparse_mat + !! \brief Make sure the entries are sorted and duplicates are handled. + !! \param info return code + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! + ! + interface + subroutine psb_ld_fix_coo(a,info,idir) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + end subroutine psb_ld_fix_coo + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo + interface + subroutine psb_ld_cp_coo_to_coo(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_coo_to_coo + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo + interface + subroutine psb_ld_cp_coo_from_coo(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_coo_from_coo + end interface + + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo + interface + subroutine psb_ld_cp_coo_to_icoo(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_coo_to_icoo + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo + interface + subroutine psb_ld_cp_coo_from_icoo(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_coo_from_icoo + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo + !! + interface + subroutine psb_ld_cp_coo_to_fmt(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_coo_to_fmt + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt + !! + interface + subroutine psb_ld_cp_coo_from_fmt(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_coo_from_fmt + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo + interface + subroutine psb_ld_mv_coo_to_coo(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_coo_to_coo + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo + interface + subroutine psb_ld_mv_coo_from_coo(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_coo_from_coo + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt + interface + subroutine psb_ld_mv_coo_to_fmt(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_coo_to_fmt + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt + interface + subroutine psb_ld_mv_coo_from_fmt(a,b,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_coo_from_fmt + end interface + + interface + subroutine psb_ld_coo_cp_from(a,b) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + type(psb_ld_coo_sparse_mat), intent(in) :: b + end subroutine psb_ld_coo_cp_from + end interface + + interface + subroutine psb_ld_coo_mv_from(a,b) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + type(psb_ld_coo_sparse_mat), intent(inout) :: b + end subroutine psb_ld_coo_mv_from + end interface + + + !> Function csput + !! \memberof psb_ld_coo_sparse_mat + !! \brief Add coefficients into the matrix. + !! + !! \param nz Number of entries to be added + !! \param ia(:) Row indices + !! \param ja(:) Col indices + !! \param val(:) Values + !! \param imin Minimum row index to accept + !! \param imax Maximum row index to accept + !! \param jmin Minimum col index to accept + !! \param jmax Maximum col index to accept + !! \param info return code + !! \param gtl [none] Renumbering for rows/columns + !! + ! + interface + subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_coo_csput_a + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_coo_csgetptn + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow + interface + subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_coo_csgetrow + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag + interface + subroutine psb_ld_coo_get_diag(a,d,info) + import + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_coo_get_diag + end interface + + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scal + interface + subroutine psb_ld_coo_scal(d,a,info,side) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ld_coo_scal + end interface + + !> + !! \memberof psb_ld_coo_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scals + interface + subroutine psb_ld_coo_scals(d,a,info) + import + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_coo_scals + end interface contains @@ -1752,11 +3453,11 @@ contains function d_coo_sizeof(a) result(res) implicit none class(psb_d_coo_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + 1 + integer(psb_epk_) :: res + res = 3*psb_sizeof_ip res = res + psb_sizeof_dp * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%ia) - res = res + psb_sizeof_int * psb_size(a%ja) + res = res + psb_sizeof_ip * psb_size(a%ia) + res = res + psb_sizeof_ip * psb_size(a%ja) end function d_coo_sizeof @@ -1902,9 +3603,9 @@ contains if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) - call a%set_nzeros(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) + call a%set_nzeros(0_psb_ipk_) call a%set_sort_status(psb_unsorted_) return @@ -1958,6 +3659,230 @@ contains end subroutine d_coo_transc_1mat + + ! == ================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == ================================== + + + + function ld_coo_sizeof(a) result(res) + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 3*psb_sizeof_lp + res = res + psb_sizeof_dp * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%ia) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function ld_coo_sizeof + + + function ld_coo_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'COO' + end function ld_coo_get_fmt + + + function ld_coo_get_size(a) result(res) + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = -1 + + if (allocated(a%ia)) res = size(a%ia) + if (allocated(a%ja)) then + if (res >= 0) then + res = min(res,size(a%ja)) + else + res = size(a%ja) + end if + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + end function ld_coo_get_size + + + function ld_coo_get_nzeros(a) result(res) + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%nnz + end function ld_coo_get_nzeros + + function ld_coo_is_by_rows(a) result(res) + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_row_major_) + end function ld_coo_is_by_rows + + function ld_coo_is_by_cols(a) result(res) + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_col_major_) + end function ld_coo_is_by_cols + + function ld_coo_is_sorted(a) result(res) + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_row_major_) & + & .or.(a%sort_status == psb_col_major_) + end function ld_coo_is_sorted + + + + ! == ================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == ================================== + + subroutine ld_coo_set_nzeros(nz,a) + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_coo_sparse_mat), intent(inout) :: a + + a%nnz = nz + + end subroutine ld_coo_set_nzeros + + function ld_coo_get_sort_status(a) result(res) + implicit none + integer(psb_ipk_) :: res + class(psb_ld_coo_sparse_mat), intent(in) :: a + + res = a%sort_status + end function ld_coo_get_sort_status + + subroutine ld_coo_set_sort_status(ist,a) + implicit none + integer(psb_ipk_), intent(in) :: ist + class(psb_ld_coo_sparse_mat), intent(inout) :: a + + a%sort_status = ist + call a%set_sorted((a%sort_status == psb_row_major_) & + & .or.(a%sort_status == psb_col_major_)) + end subroutine ld_coo_set_sort_status + + + subroutine ld_coo_set_by_rows(a) + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + + a%sort_status = psb_row_major_ + call a%set_sorted() + end subroutine ld_coo_set_by_rows + + + subroutine ld_coo_set_by_cols(a) + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + + a%sort_status = psb_col_major_ + call a%set_sorted() + end subroutine ld_coo_set_by_cols + + ! == ================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == ================================== + + subroutine ld_coo_free(a) + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + call a%set_nzeros(0_psb_lpk_) + call a%set_sort_status(psb_unsorted_) + + return + + end subroutine ld_coo_free + + + + ! == ================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + ! == ================================== + subroutine ld_coo_transp_1mat(a) + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + + integer(psb_lpk_), allocatable :: itemp(:) + integer(psb_ipk_) :: info + + call a%psb_ld_base_sparse_mat%psb_lbase_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%set_sorted(.false.) + call a%set_sort_status(psb_unsorted_) + + return + + end subroutine ld_coo_transp_1mat + + subroutine ld_coo_transc_1mat(a) + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + + call a%transp() + ! This will morph into conjg() for C and Z + ! and into a no-op for S and D, so a conditional + ! on a constant ought to take it out completely. + if (psb_ld_is_complex_) a%val(:) = (a%val(:)) + + end subroutine ld_coo_transc_1mat + end module psb_d_base_mat_mod diff --git a/base/modules/serial/psb_d_base_vect_mod.f90 b/base/modules/serial/psb_d_base_vect_mod.f90 index 3413a6dad..8a59b5134 100644 --- a/base/modules/serial/psb_d_base_vect_mod.f90 +++ b/base/modules/serial/psb_d_base_vect_mod.f90 @@ -48,6 +48,7 @@ module psb_d_base_vect_mod use psb_error_mod use psb_realloc_mod use psb_i_base_vect_mod + use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_d_base_vect_type !! The psb_d_base_vect_type @@ -63,14 +64,15 @@ module psb_d_base_vect_mod !> Values. real(psb_dpk_), allocatable :: v(:) real(psb_dpk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators ! procedure, pass(x) :: bld_x => d_base_bld_x - procedure, pass(x) :: bld_n => d_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => d_base_bld_mn + procedure, pass(x) :: bld_en => d_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => d_base_all procedure, pass(x) :: mold => d_base_mold ! @@ -82,7 +84,9 @@ module psb_d_base_vect_mod procedure, pass(x) :: ins_v => d_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => d_base_zero - procedure, pass(x) :: asb => d_base_asb + procedure, pass(x) :: asb_m => d_base_asb_m + procedure, pass(x) :: asb_e => d_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => d_base_free ! ! Sync: centerpiece of handling of external storage. @@ -240,22 +244,39 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_d_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine d_base_bld_n(x,n) + subroutine d_base_bld_mn(x,n) use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine d_base_bld_n + end subroutine d_base_bld_mn + + !> Function bld_en: + !! \memberof psb_d_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine d_base_bld_en(x,n) + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine d_base_bld_en !> Function base_all: !! \memberof psb_d_base_vect_type @@ -437,11 +458,11 @@ contains !! ! - subroutine d_base_asb(n, x, info) + subroutine d_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -451,7 +472,37 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine d_base_asb + end subroutine d_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_d_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine d_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine d_base_asb_e ! !> Function base_free: @@ -662,10 +713,10 @@ contains function d_base_sizeof(x) result(res) implicit none class(psb_d_base_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * psb_sizeof_dp) * x%get_nrows() + res = (1_psb_epk_ * psb_sizeof_dp) * x%get_nrows() end function d_base_sizeof @@ -753,7 +804,6 @@ contains integer(psb_ipk_) :: info, first_, last_, nr - first_ = 1 if (present(first)) first_ = max(1,first) last_ = min(psb_size(x%v),first_+size(val)-1) @@ -1415,7 +1465,7 @@ module psb_d_base_multivect_mod !> Values. real(psb_dpk_), allocatable :: v(:,:) real(psb_dpk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1933,10 +1983,10 @@ contains function d_base_mlv_sizeof(x) result(res) implicit none class(psb_d_base_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() end function d_base_mlv_sizeof diff --git a/base/modules/serial/psb_d_csc_mat_mod.f90 b/base/modules/serial/psb_d_csc_mat_mod.f90 index 7e4d555c1..8577ba31b 100644 --- a/base/modules/serial/psb_d_csc_mat_mod.f90 +++ b/base/modules/serial/psb_d_csc_mat_mod.f90 @@ -100,14 +100,69 @@ module psb_d_csc_mat_mod end type psb_d_csc_sparse_mat - private :: d_csc_get_nzeros, d_csc_free, d_csc_get_fmt, & + private :: d_csc_get_nzeros, d_csc_free, d_csc_get_fmt, & & d_csc_get_size, d_csc_sizeof, d_csc_get_nz_col + + !> \namespace psb_base_mod \class psb_d_csc_sparse_mat + !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat + !! + !! psb_d_csc_sparse_mat type and the related methods. + !! + type, extends(psb_ld_base_sparse_mat) :: psb_ld_csc_sparse_mat + + !> Pointers to beginning of cols in IA and VAL. + integer(psb_lpk_), allocatable :: icp(:) + !> Row indices. + integer(psb_lpk_), allocatable :: ia(:) + !> Coefficient values. + real(psb_dpk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_cols => ld_csc_is_by_cols + procedure, pass(a) :: get_size => ld_csc_get_size + procedure, pass(a) :: get_nzeros => ld_csc_get_nzeros + procedure, nopass :: get_fmt => ld_csc_get_fmt + procedure, pass(a) :: sizeof => ld_csc_sizeof + procedure, pass(a) :: scals => psb_ld_csc_scals + procedure, pass(a) :: scalv => psb_ld_csc_scal + procedure, pass(a) :: maxval => psb_ld_csc_maxval + procedure, pass(a) :: spnm1 => psb_ld_csc_csnm1 + procedure, pass(a) :: rowsum => psb_ld_csc_rowsum + procedure, pass(a) :: arwsum => psb_ld_csc_arwsum + procedure, pass(a) :: colsum => psb_ld_csc_colsum + procedure, pass(a) :: aclsum => psb_ld_csc_aclsum + procedure, pass(a) :: reallocate_nz => psb_ld_csc_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_ld_csc_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_ld_cp_csc_to_coo + procedure, pass(a) :: cp_from_coo => psb_ld_cp_csc_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ld_cp_csc_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ld_cp_csc_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ld_mv_csc_to_coo + procedure, pass(a) :: mv_from_coo => psb_ld_mv_csc_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ld_mv_csc_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ld_mv_csc_from_fmt + procedure, pass(a) :: csput_a => psb_ld_csc_csput_a + procedure, pass(a) :: get_diag => psb_ld_csc_get_diag + procedure, pass(a) :: csgetptn => psb_ld_csc_csgetptn + procedure, pass(a) :: csgetrow => psb_ld_csc_csgetrow + procedure, pass(a) :: get_nz_col => ld_csc_get_nz_col + procedure, pass(a) :: reinit => psb_ld_csc_reinit + procedure, pass(a) :: trim => psb_ld_csc_trim + procedure, pass(a) :: print => psb_ld_csc_print + procedure, pass(a) :: free => ld_csc_free + procedure, pass(a) :: mold => psb_ld_csc_mold + + end type psb_ld_csc_sparse_mat + + private :: ld_csc_get_nzeros, ld_csc_free, ld_csc_get_fmt, & + & ld_csc_get_size, ld_csc_sizeof, ld_csc_get_nz_col + !> \memberof psb_d_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface subroutine psb_d_csc_reallocate_nz(nz,a) - import :: psb_ipk_, psb_d_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_d_csc_sparse_mat), intent(inout) :: a end subroutine psb_d_csc_reallocate_nz @@ -117,7 +172,7 @@ module psb_d_csc_mat_mod !| \see psb_base_mat_mod::psb_base_reinit interface subroutine psb_d_csc_reinit(a,clear) - import :: psb_ipk_, psb_d_csc_sparse_mat + import class(psb_d_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_d_csc_reinit @@ -127,7 +182,7 @@ module psb_d_csc_mat_mod !| \see psb_base_mat_mod::psb_base_trim interface subroutine psb_d_csc_trim(a) - import :: psb_ipk_, psb_d_csc_sparse_mat + import class(psb_d_csc_sparse_mat), intent(inout) :: a end subroutine psb_d_csc_trim end interface @@ -136,7 +191,7 @@ module psb_d_csc_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_d_csc_mold(a,b,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ + import class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -147,7 +202,7 @@ module psb_d_csc_mat_mod !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface subroutine psb_d_csc_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_d_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_d_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -159,7 +214,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_print interface subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_d_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_d_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -172,7 +227,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_to_coo interface subroutine psb_d_cp_csc_to_coo(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_csc_sparse_mat + import class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -183,7 +238,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo interface subroutine psb_d_cp_csc_from_coo(a,b,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_coo_sparse_mat + import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -194,7 +249,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_to_fmt interface subroutine psb_d_cp_csc_to_fmt(a,b,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -205,7 +260,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_from_fmt interface subroutine psb_d_cp_csc_from_fmt(a,b,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -216,7 +271,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_to_coo interface subroutine psb_d_mv_csc_to_coo(a,b,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_coo_sparse_mat + import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -227,7 +282,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_from_coo interface subroutine psb_d_mv_csc_from_coo(a,b,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_coo_sparse_mat + import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -238,7 +293,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_to_fmt interface subroutine psb_d_mv_csc_to_fmt(a,b,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -249,7 +304,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_from_fmt interface subroutine psb_d_mv_csc_from_fmt(a,b,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_csc_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -260,7 +315,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_from interface subroutine psb_d_csc_cp_from(a,b) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(inout) :: a type(psb_d_csc_sparse_mat), intent(in) :: b end subroutine psb_d_csc_cp_from @@ -270,7 +325,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_from interface subroutine psb_d_csc_mv_from(a,b) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(inout) :: a type(psb_d_csc_sparse_mat), intent(inout) :: b end subroutine psb_d_csc_mv_from @@ -281,7 +336,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csput_a interface subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -296,7 +351,7 @@ module psb_d_csc_mat_mod interface subroutine psb_d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -328,28 +383,28 @@ module psb_d_csc_mat_mod end subroutine psb_d_csc_csgetrow end interface -!!$ !> \memberof psb_d_csc_sparse_mat -!!$ !! \see psb_d_base_mat_mod::psb_d_base_csgetblk -!!$ interface -!!$ subroutine psb_d_csc_csgetblk(imin,imax,a,b,info,& -!!$ & jmin,jmax,iren,append,rscale,cscale,chksz) -!!$ import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_, psb_d_coo_sparse_mat -!!$ class(psb_d_csc_sparse_mat), intent(in) :: a -!!$ class(psb_d_coo_sparse_mat), intent(inout) :: b -!!$ integer(psb_ipk_), intent(in) :: imin,imax -!!$ integer(psb_ipk_),intent(out) :: info -!!$ logical, intent(in), optional :: append -!!$ integer(psb_ipk_), intent(in), optional :: iren(:) -!!$ integer(psb_ipk_), intent(in), optional :: jmin,jmax -!!$ logical, intent(in), optional :: rscale,cscale,chksz -!!$ end subroutine psb_d_csc_csgetblk -!!$ end interface -!!$ + !> \memberof psb_d_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_d_base_csgetblk + interface + subroutine psb_d_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale,chksz) + import + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale,chksz + end subroutine psb_d_csc_csgetblk + end interface + !> \memberof psb_d_csc_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cssv interface subroutine psb_d_csc_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -361,7 +416,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cssm interface subroutine psb_d_csc_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -374,7 +429,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csmv interface subroutine psb_d_csc_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -387,7 +442,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csmm interface subroutine psb_d_csc_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -401,7 +456,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_maxval interface function psb_d_csc_maxval(a) result(res) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csc_maxval @@ -411,7 +466,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csnm1 interface function psb_d_csc_csnm1(a) result(res) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csc_csnm1 @@ -421,7 +476,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_rowsum interface subroutine psb_d_csc_rowsum(d,a) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csc_rowsum @@ -431,7 +486,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_arwsum interface subroutine psb_d_csc_arwsum(d,a) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csc_arwsum @@ -441,7 +496,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_colsum interface subroutine psb_d_csc_colsum(d,a) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csc_colsum @@ -451,7 +506,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_aclsum interface subroutine psb_d_csc_aclsum(d,a) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csc_aclsum @@ -461,7 +516,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_get_diag interface subroutine psb_d_csc_get_diag(a,d,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -472,7 +527,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_scal interface subroutine psb_d_csc_scal(d,a,info,side) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -484,7 +539,7 @@ module psb_d_csc_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_scals interface subroutine psb_d_csc_scals(d,a,info) - import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_ + import class(psb_d_csc_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -492,6 +547,347 @@ module psb_d_csc_mat_mod end interface + ! + ! ld + ! + !> \memberof psb_ld_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_ld_csc_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_csc_sparse_mat), intent(inout) :: a + end subroutine psb_ld_csc_reallocate_nz + end interface + + !> \memberof psb_ld_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_ld_csc_reinit(a,clear) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ld_csc_reinit + end interface + + !> \memberof psb_ld_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_ld_csc_trim(a) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + end subroutine psb_ld_csc_trim + end interface + + !> \memberof psb_ld_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_ld_csc_mold(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csc_mold + end interface + + !> \memberof psb_ld_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ld_csc_allocate_mnnz + end interface + + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_print + interface + subroutine psb_ld_csc_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_csc_print + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo + interface + subroutine psb_ld_cp_csc_to_coo(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csc_to_coo + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo + interface + subroutine psb_ld_cp_csc_from_coo(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csc_from_coo + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_fmt + interface + subroutine psb_ld_cp_csc_to_fmt(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csc_to_fmt + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt + interface + subroutine psb_ld_cp_csc_from_fmt(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csc_from_fmt + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo + interface + subroutine psb_ld_mv_csc_to_coo(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csc_to_coo + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo + interface + subroutine psb_ld_mv_csc_from_coo(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csc_from_coo + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt + interface + subroutine psb_ld_mv_csc_to_fmt(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csc_to_fmt + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt + interface + subroutine psb_ld_mv_csc_from_fmt(a,b,info) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csc_from_fmt + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from + interface + subroutine psb_ld_csc_cp_from(a,b) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + type(psb_ld_csc_sparse_mat), intent(in) :: b + end subroutine psb_ld_csc_cp_from + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from + interface + subroutine psb_ld_csc_mv_from(a,b) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + type(psb_ld_csc_sparse_mat), intent(inout) :: b + end subroutine psb_ld_csc_mv_from + end interface + + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a + interface + subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_csc_csput_a + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_ld_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csc_csgetptn + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow + interface + subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csc_csgetrow + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csgetblk + interface + subroutine psb_ld_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csc_csgetblk + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag + interface + subroutine psb_ld_csc_get_diag(a,d,info) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csc_get_diag + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_maxval + interface + function psb_ld_csc_maxval(a) result(res) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csc_maxval + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_csnm1 + interface + function psb_ld_csc_csnm1(a) result(res) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csc_csnm1 + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_rowsum + interface + subroutine psb_ld_csc_rowsum(d,a) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csc_rowsum + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_arwsum + interface + subroutine psb_ld_csc_arwsum(d,a) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csc_arwsum + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_colsum + interface + subroutine psb_ld_csc_colsum(d,a) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csc_colsum + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_aclsum + interface + subroutine psb_ld_csc_aclsum(d,a) + import + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csc_aclsum + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scal + interface + subroutine psb_ld_csc_scal(d,a,info,side) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ld_csc_scal + end interface + + !> \memberof psb_ld_csc_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scals + interface + subroutine psb_ld_csc_scals(d,a,info) + import + class(psb_ld_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csc_scals + end interface + + + contains ! == =================================== @@ -519,11 +915,11 @@ contains function d_csc_sizeof(a) result(res) implicit none class(psb_d_csc_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + integer(psb_epk_) :: res + res = 2 * psb_sizeof_ip res = res + psb_sizeof_dp * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%icp) - res = res + psb_sizeof_int * psb_size(a%ia) + res = res + psb_sizeof_ip * psb_size(a%icp) + res = res + psb_sizeof_ip * psb_size(a%ia) end function d_csc_sizeof @@ -602,11 +998,133 @@ contains if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) return end subroutine d_csc_free + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function ld_csc_is_by_cols(a) result(res) + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function ld_csc_is_by_cols + + ! + ! ld + ! + + function ld_csc_sizeof(a) result(res) + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2*psb_sizeof_lp + res = res + psb_sizeof_dp * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%icp) + res = res + psb_sizeof_lp * psb_size(a%ia) + + end function ld_csc_sizeof + + function ld_csc_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSC' + end function ld_csc_get_fmt + + function ld_csc_get_nzeros(a) result(res) + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%icp(a%get_ncols()+1)-1 + end function ld_csc_get_nzeros + + function ld_csc_get_size(a) result(res) + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ia)) then + res = size(a%ia) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function ld_csc_get_size + + + + function ld_csc_get_nz_col(idx,a) result(res) + use psb_const_mod + implicit none + + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then + res = a%icp(idx+1)-a%icp(idx) + end if + + end function ld_csc_get_nz_col + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + + subroutine ld_csc_free(a) + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + + if (allocated(a%icp)) deallocate(a%icp) + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine ld_csc_free + + + end module psb_d_csc_mat_mod diff --git a/base/modules/serial/psb_d_csr_mat_mod.f90 b/base/modules/serial/psb_d_csr_mat_mod.f90 index 8ba73b154..7dd197de5 100644 --- a/base/modules/serial/psb_d_csr_mat_mod.f90 +++ b/base/modules/serial/psb_d_csr_mat_mod.f90 @@ -111,7 +111,7 @@ module psb_d_csr_mat_mod !| \see psb_base_mat_mod::psb_base_reallocate_nz interface subroutine psb_d_csr_reallocate_nz(nz,a) - import :: psb_ipk_, psb_d_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_d_csr_sparse_mat), intent(inout) :: a end subroutine psb_d_csr_reallocate_nz @@ -121,7 +121,7 @@ module psb_d_csr_mat_mod !| \see psb_base_mat_mod::psb_base_reinit interface subroutine psb_d_csr_reinit(a,clear) - import :: psb_ipk_, psb_d_csr_sparse_mat + import class(psb_d_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_d_csr_reinit @@ -131,7 +131,7 @@ module psb_d_csr_mat_mod !| \see psb_base_mat_mod::psb_base_trim interface subroutine psb_d_csr_trim(a) - import :: psb_ipk_, psb_d_csr_sparse_mat + import class(psb_d_csr_sparse_mat), intent(inout) :: a end subroutine psb_d_csr_trim end interface @@ -141,7 +141,7 @@ module psb_d_csr_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_d_csr_mold(a,b,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ + import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -152,7 +152,7 @@ module psb_d_csr_mat_mod !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_d_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_d_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -164,7 +164,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_print interface subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_d_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -205,7 +205,7 @@ module psb_d_csr_mat_mod interface subroutine psb_d_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -249,7 +249,7 @@ module psb_d_csr_mat_mod interface subroutine psb_d_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_coo_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -264,7 +264,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_to_coo interface subroutine psb_d_cp_csr_to_coo(a,b,info) - import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_csr_sparse_mat + import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -275,7 +275,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_from_coo interface subroutine psb_d_cp_csr_from_coo(a,b,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_coo_sparse_mat + import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -286,7 +286,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_to_fmt interface subroutine psb_d_cp_csr_to_fmt(a,b,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -297,7 +297,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_from_fmt interface subroutine psb_d_cp_csr_from_fmt(a,b,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -308,7 +308,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_to_coo interface subroutine psb_d_mv_csr_to_coo(a,b,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_coo_sparse_mat + import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -319,7 +319,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_from_coo interface subroutine psb_d_mv_csr_from_coo(a,b,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_coo_sparse_mat + import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -330,7 +330,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_to_fmt interface subroutine psb_d_mv_csr_to_fmt(a,b,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -341,7 +341,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_from_fmt interface subroutine psb_d_mv_csr_from_fmt(a,b,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_base_sparse_mat + import class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -352,7 +352,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cp_from interface subroutine psb_d_csr_cp_from(a,b) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(inout) :: a type(psb_d_csr_sparse_mat), intent(in) :: b end subroutine psb_d_csr_cp_from @@ -362,7 +362,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_mv_from interface subroutine psb_d_csr_mv_from(a,b) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(inout) :: a type(psb_d_csr_sparse_mat), intent(inout) :: b end subroutine psb_d_csr_mv_from @@ -373,7 +373,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csput_a interface subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -388,7 +388,7 @@ module psb_d_csr_mat_mod interface subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -406,7 +406,7 @@ module psb_d_csr_mat_mod interface subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -419,29 +419,12 @@ module psb_d_csr_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_d_csr_csgetrow end interface -!!$ -!!$ !> \memberof psb_d_csr_sparse_mat -!!$ !! \see psb_d_base_mat_mod::psb_d_base_csgetblk -!!$ interface -!!$ subroutine psb_d_csr_csgetblk(imin,imax,a,b,info,& -!!$ & jmin,jmax,iren,append,rscale,cscale) -!!$ import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_, psb_d_coo_sparse_mat -!!$ class(psb_d_csr_sparse_mat), intent(in) :: a -!!$ class(psb_d_coo_sparse_mat), intent(inout) :: b -!!$ integer(psb_ipk_), intent(in) :: imin,imax -!!$ integer(psb_ipk_),intent(out) :: info -!!$ logical, intent(in), optional :: append -!!$ integer(psb_ipk_), intent(in), optional :: iren(:) -!!$ integer(psb_ipk_), intent(in), optional :: jmin,jmax -!!$ logical, intent(in), optional :: rscale,cscale -!!$ end subroutine psb_d_csr_csgetblk -!!$ end interface - + !> \memberof psb_d_csr_sparse_mat !! \see psb_d_base_mat_mod::psb_d_base_cssv interface subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -453,7 +436,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_cssm interface subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -466,7 +449,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csmv interface subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(inout) :: y(:) @@ -479,7 +462,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csmm interface subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) @@ -493,7 +476,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_maxval interface function psb_d_csr_maxval(a) result(res) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csr_maxval @@ -503,7 +486,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_csnmi interface function psb_d_csr_csnmi(a) result(res) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_d_csr_csnmi @@ -513,7 +496,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_rowsum interface subroutine psb_d_csr_rowsum(d,a) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csr_rowsum @@ -523,7 +506,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_arwsum interface subroutine psb_d_csr_arwsum(d,a) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csr_arwsum @@ -533,7 +516,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_colsum interface subroutine psb_d_csr_colsum(d,a) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csr_colsum @@ -543,7 +526,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_aclsum interface subroutine psb_d_csr_aclsum(d,a) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_d_csr_aclsum @@ -553,7 +536,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_get_diag interface subroutine psb_d_csr_get_diag(a,d,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -564,7 +547,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_scal interface subroutine psb_d_csr_scal(d,a,info,side) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -576,7 +559,7 @@ module psb_d_csr_mat_mod !! \see psb_d_base_mat_mod::psb_d_base_scals interface subroutine psb_d_csr_scals(d,a,info) - import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_ + import class(psb_d_csr_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -584,6 +567,471 @@ module psb_d_csr_mat_mod end interface + !> \namespace psb_base_mod \class psb_ld_csr_sparse_mat + !! \extends psb_ld_base_mat_mod::psb_ld_base_sparse_mat + !! + !! psb_ld_csr_sparse_mat type and the related methods. + !! This is a very common storage type, and is the default for assembled + !! matrices in our library + type, extends(psb_ld_base_sparse_mat) :: psb_ld_csr_sparse_mat + + !> Pointers to beginning of rows in JA and VAL. + integer(psb_lpk_), allocatable :: irp(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + real(psb_dpk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_rows => ld_csr_is_by_rows + procedure, pass(a) :: get_size => ld_csr_get_size + procedure, pass(a) :: get_nzeros => ld_csr_get_nzeros + procedure, nopass :: get_fmt => ld_csr_get_fmt + procedure, pass(a) :: sizeof => ld_csr_sizeof + procedure, pass(a) :: reallocate_nz => psb_ld_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_ld_csr_allocate_mnnz + procedure, pass(a) :: tril => psb_ld_csr_tril + procedure, pass(a) :: triu => psb_ld_csr_triu + procedure, pass(a) :: cp_to_coo => psb_ld_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_ld_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ld_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ld_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ld_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_ld_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ld_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ld_mv_csr_from_fmt + procedure, pass(a) :: csput_a => psb_ld_csr_csput_a + procedure, pass(a) :: get_diag => psb_ld_csr_get_diag + procedure, pass(a) :: csgetptn => psb_ld_csr_csgetptn + procedure, pass(a) :: csgetrow => psb_ld_csr_csgetrow + procedure, pass(a) :: get_nz_row => ld_csr_get_nz_row + procedure, pass(a) :: reinit => psb_ld_csr_reinit + procedure, pass(a) :: trim => psb_ld_csr_trim + procedure, pass(a) :: print => psb_ld_csr_print + procedure, pass(a) :: free => ld_csr_free + procedure, pass(a) :: mold => psb_ld_csr_mold + procedure, pass(a) :: scals => psb_ld_csr_scals + procedure, pass(a) :: scalv => psb_ld_csr_scal + procedure, pass(a) :: maxval => psb_ld_csr_maxval + procedure, pass(a) :: spnmi => psb_ld_csr_csnmi + procedure, pass(a) :: rowsum => psb_ld_csr_rowsum + procedure, pass(a) :: arwsum => psb_ld_csr_arwsum + procedure, pass(a) :: colsum => psb_ld_csr_colsum + procedure, pass(a) :: aclsum => psb_ld_csr_aclsum + + end type psb_ld_csr_sparse_mat + + private :: ld_csr_get_nzeros, ld_csr_free, ld_csr_get_fmt, & + & ld_csr_get_size, ld_csr_sizeof, ld_csr_get_nz_row, & + & ld_csr_is_by_rows + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_ld_csr_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_csr_sparse_mat), intent(inout) :: a + end subroutine psb_ld_csr_reallocate_nz + end interface + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_ld_csr_reinit(a,clear) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ld_csr_reinit + end interface + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_ld_csr_trim(a) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + end subroutine psb_ld_csr_trim + end interface + + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_ld_csr_mold(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csr_mold + end interface + + !> \memberof psb_ld_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ld_csr_allocate_mnnz + end interface + + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_print + interface + subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_csr_print + end interface + ! + !> Function tril: + !! \memberof psb_d_base_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_ld_csr_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_ld_csr_tril + end interface + + ! + !> Function triu: + !! \memberof psb_d_csr_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_ld_csr_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_ld_csr_triu + end interface + + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_coo + interface + subroutine psb_ld_cp_csr_to_coo(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csr_to_coo + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_coo + interface + subroutine psb_ld_cp_csr_from_coo(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csr_from_coo + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_to_fmt + interface + subroutine psb_ld_cp_csr_to_fmt(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csr_to_fmt + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from_fmt + interface + subroutine psb_ld_cp_csr_from_fmt(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_cp_csr_from_fmt + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_coo + interface + subroutine psb_ld_mv_csr_to_coo(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csr_to_coo + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_coo + interface + subroutine psb_ld_mv_csr_from_coo(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csr_from_coo + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_to_fmt + interface + subroutine psb_ld_mv_csr_to_fmt(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csr_to_fmt + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from_fmt + interface + subroutine psb_ld_mv_csr_from_fmt(a,b,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_mv_csr_from_fmt + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_cp_from + interface + subroutine psb_ld_csr_cp_from(a,b) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + type(psb_ld_csr_sparse_mat), intent(in) :: b + end subroutine psb_ld_csr_cp_from + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_mv_from + interface + subroutine psb_ld_csr_mv_from(a,b) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + type(psb_ld_csr_sparse_mat), intent(inout) :: b + end subroutine psb_ld_csr_mv_from + end interface + + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csput_a + interface + subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_csr_csput_a + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csr_csgetptn + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_csgetrow + interface + subroutine psb_ld_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csr_csgetrow + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_get_diag + interface + subroutine psb_ld_csr_get_diag(a,d,info) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csr_get_diag + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scal + interface + subroutine psb_ld_csr_scal(d,a,info,side) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ld_csr_scal + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_ld_base_mat_mod::psb_ld_base_scals + interface + subroutine psb_ld_csr_scals(d,a,info) + import + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_csr_scals + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_maxval + interface + function psb_ld_csr_maxval(a) result(res) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csr_maxval + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_csnmi + interface + function psb_ld_csr_csnmi(a) result(res) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csr_csnmi + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_rowsum + interface + subroutine psb_ld_csr_rowsum(d,a) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csr_rowsum + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_arwsum + interface + subroutine psb_ld_csr_arwsum(d,a) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csr_arwsum + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_colsum + interface + subroutine psb_ld_csr_colsum(d,a) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csr_colsum + end interface + + !> \memberof psb_ld_csr_sparse_mat + !! \see psb_d_base_mat_mod::psb_ld_base_aclsum + interface + subroutine psb_ld_csr_aclsum(d,a) + import + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_ld_csr_aclsum + end interface + contains @@ -613,11 +1061,11 @@ contains function d_csr_sizeof(a) result(res) implicit none class(psb_d_csr_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + integer(psb_epk_) :: res + res = 2 * psb_sizeof_ip res = res + psb_sizeof_dp * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%irp) - res = res + psb_sizeof_int * psb_size(a%ja) + res = res + psb_sizeof_ip * psb_size(a%irp) + res = res + psb_sizeof_ip * psb_size(a%ja) end function d_csr_sizeof @@ -695,12 +1143,128 @@ contains if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) return end subroutine d_csr_free + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + + function ld_csr_is_by_rows(a) result(res) + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function ld_csr_is_by_rows + + + function ld_csr_sizeof(a) result(res) + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2 * psb_sizeof_lp + res = res + psb_sizeof_dp * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function ld_csr_sizeof + + function ld_csr_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSR' + end function ld_csr_get_fmt + + function ld_csr_get_nzeros(a) result(res) + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%irp(a%get_nrows()+1)-1 + end function ld_csr_get_nzeros + + function ld_csr_get_size(a) result(res) + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ja)) then + res = size(a%ja) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function ld_csr_get_size + + + + function ld_csr_get_nz_row(idx,a) result(res) + + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function ld_csr_get_nz_row + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + subroutine ld_csr_free(a) + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine ld_csr_free + end module psb_d_csr_mat_mod diff --git a/base/modules/serial/psb_d_mat_mod.F90 b/base/modules/serial/psb_d_mat_mod.F90 new file mode 100644 index 000000000..bd24197c7 --- /dev/null +++ b/base/modules/serial/psb_d_mat_mod.F90 @@ -0,0 +1,2740 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_d_mat_mod +! +! This module contains the definition of the psb_d_sparse type which +! is a generic container for a sparse matrix and it is mostly meant to +! provide a mean of switching, at run-time, among different formats, +! potentially unknown at the library compile-time by adding a layer of +! indirection. This type encapsulates the psb_d_base_sparse_mat class +! inside another class which is the one visible to the user. +! Most methods of the psb_d_mat_mod simply call the methods of the +! encapsulated class. +! The exceptions are mainly cscnv and cp_from/cp_to; these provide +! the functionalities to have the encapsulated class change its +! type dynamically, and to extract/input an inner object. +! +! A sparse matrix has a state corresponding to its progression +! through the application life. +! In particular, computational methods can only be invoked when +! the matrix is in the ASSEMBLED state, whereas the other states are +! dedicated to operations on the internal matrix data. +! A sparse matrix can move between states according to the +! following state transition table. Associated with these states are +! the possible dynamic types of the inner matrix object. +! Only COO matrices can ever be in the BUILD state, whereas +! the ASSEMBLED and UPDATE state can be entered by any class. +! +! In Out Method +!| ---------------------------------- +!| Null Build csall +!| Build Build csput +!| Build Assembled cscnv +!| Assembled Assembled cscnv +!| Assembled Update reinit +!| Update Update csput +!| Update Assembled cscnv +!| * unchanged reall +!| Assembled Null free +! +! +! +! We are also introducing the type psb_ldspmat_type. +! The basic difference with psb_dspmat_type is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! +module psb_d_mat_mod + + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat, psb_ld_csr_sparse_mat + use psb_d_csc_mat_mod, only : psb_d_csc_sparse_mat, psb_ld_csc_sparse_mat + + type :: psb_dspmat_type + + class(psb_d_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_d_get_nrows + procedure, pass(a) :: get_ncols => psb_d_get_ncols + procedure, pass(a) :: get_nzeros => psb_d_get_nzeros + procedure, pass(a) :: get_nz_row => psb_d_get_nz_row + procedure, pass(a) :: get_size => psb_d_get_size + procedure, pass(a) :: get_dupl => psb_d_get_dupl + procedure, pass(a) :: is_null => psb_d_is_null + procedure, pass(a) :: is_bld => psb_d_is_bld + procedure, pass(a) :: is_upd => psb_d_is_upd + procedure, pass(a) :: is_asb => psb_d_is_asb + procedure, pass(a) :: is_sorted => psb_d_is_sorted + procedure, pass(a) :: is_by_rows => psb_d_is_by_rows + procedure, pass(a) :: is_by_cols => psb_d_is_by_cols + procedure, pass(a) :: is_upper => psb_d_is_upper + procedure, pass(a) :: is_lower => psb_d_is_lower + procedure, pass(a) :: is_triangle => psb_d_is_triangle + procedure, pass(a) :: is_unit => psb_d_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_d_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_d_get_fmt + procedure, pass(a) :: sizeof => psb_d_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_d_set_nrows + procedure, pass(a) :: set_ncols => psb_d_set_ncols + procedure, pass(a) :: set_dupl => psb_d_set_dupl + procedure, pass(a) :: set_null => psb_d_set_null + procedure, pass(a) :: set_bld => psb_d_set_bld + procedure, pass(a) :: set_upd => psb_d_set_upd + procedure, pass(a) :: set_asb => psb_d_set_asb + procedure, pass(a) :: set_sorted => psb_d_set_sorted + procedure, pass(a) :: set_upper => psb_d_set_upper + procedure, pass(a) :: set_lower => psb_d_set_lower + procedure, pass(a) :: set_triangle => psb_d_set_triangle + procedure, pass(a) :: set_unit => psb_d_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_d_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_d_csall + procedure, pass(a) :: free => psb_d_free + procedure, pass(a) :: trim => psb_d_trim + procedure, pass(a) :: csput_a => psb_d_csput_a + procedure, pass(a) :: csput_v => psb_d_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_d_csgetptn + procedure, pass(a) :: csgetrow => psb_d_csgetrow + procedure, pass(a) :: csgetblk => psb_d_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: lcsgetptn => psb_d_lcsgetptn + procedure, pass(a) :: lcsgetrow => psb_d_lcsgetrow + generic, public :: csget => lcsgetptn, lcsgetrow +#endif + procedure, pass(a) :: tril => psb_d_tril + procedure, pass(a) :: triu => psb_d_triu + procedure, pass(a) :: m_csclip => psb_d_csclip + procedure, pass(a) :: b_csclip => psb_d_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_d_clean_zeros + procedure, pass(a) :: reall => psb_d_reallocate_nz + procedure, pass(a) :: get_neigh => psb_d_get_neigh + procedure, pass(a) :: reinit => psb_d_reinit + procedure, pass(a) :: print_i => psb_d_sparse_print + procedure, pass(a) :: print_n => psb_d_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_d_mold + procedure, pass(a) :: asb => psb_d_asb + procedure, pass(a) :: transp_1mat => psb_d_transp_1mat + procedure, pass(a) :: transp_2mat => psb_d_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_d_transc_1mat + procedure, pass(a) :: transc_2mat => psb_d_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => d_mat_sync + procedure, pass(a) :: is_host => d_mat_is_host + procedure, pass(a) :: is_dev => d_mat_is_dev + procedure, pass(a) :: is_sync => d_mat_is_sync + procedure, pass(a) :: set_host => d_mat_set_host + procedure, pass(a) :: set_dev => d_mat_set_dev + procedure, pass(a) :: set_sync => d_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_d_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_d_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_d_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_d_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: clip_d_ip => psb_d_clip_d_ip + procedure, pass(a) :: clip_d => psb_d_clip_d + generic, public :: clip_diag => clip_d_ip, clip_d + procedure, pass(a) :: cscnv_np => psb_d_cscnv + procedure, pass(a) :: cscnv_ip => psb_d_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_d_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_dspmat_clone + ! + ! To/from ld + ! + procedure, pass(a) :: mv_from_lb => psb_d_mv_from_lb + procedure, pass(a) :: mv_to_lb => psb_d_mv_to_lb + procedure, pass(a) :: cp_from_lb => psb_d_cp_from_lb + procedure, pass(a) :: cp_to_lb => psb_d_cp_to_lb + procedure, pass(a) :: mv_from_l => psb_d_mv_from_l + procedure, pass(a) :: mv_to_l => psb_d_mv_to_l + procedure, pass(a) :: cp_from_l => psb_d_cp_from_l + procedure, pass(a) :: cp_to_l => psb_d_cp_to_l + generic, public :: mv_from => mv_from_lb, mv_from_l + generic, public :: mv_to => mv_to_lb, mv_to_l + generic, public :: cp_from => cp_from_lb, cp_from_l + generic, public :: cp_to => cp_to_lb, cp_to_l + + ! Computational routines + procedure, pass(a) :: get_diag => psb_d_get_diag + procedure, pass(a) :: maxval => psb_d_maxval + procedure, pass(a) :: spnmi => psb_d_csnmi + procedure, pass(a) :: spnm1 => psb_d_csnm1 + procedure, pass(a) :: rowsum => psb_d_rowsum + procedure, pass(a) :: arwsum => psb_d_arwsum + procedure, pass(a) :: colsum => psb_d_colsum + procedure, pass(a) :: aclsum => psb_d_aclsum + procedure, pass(a) :: csmv_v => psb_d_csmv_vect + procedure, pass(a) :: csmv => psb_d_csmv + procedure, pass(a) :: csmm => psb_d_csmm + generic, public :: spmm => csmm, csmv, csmv_v + procedure, pass(a) :: scals => psb_d_scals + procedure, pass(a) :: scalv => psb_d_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: cssv_v => psb_d_cssv_vect + procedure, pass(a) :: cssv => psb_d_cssv + procedure, pass(a) :: cssm => psb_d_cssm + generic, public :: spsm => cssm, cssv, cssv_v + + end type psb_dspmat_type + + private :: psb_d_get_nrows, psb_d_get_ncols, & + & psb_d_get_nzeros, psb_d_get_size, & + & psb_d_get_dupl, psb_d_is_null, psb_d_is_bld, & + & psb_d_is_upd, psb_d_is_asb, psb_d_is_sorted, & + & psb_d_is_by_rows, psb_d_is_by_cols, psb_d_is_upper, & + & psb_d_is_lower, psb_d_is_triangle, psb_d_get_nz_row, & + & d_mat_sync, d_mat_is_host, d_mat_is_dev, & + & d_mat_is_sync, d_mat_set_host, d_mat_set_dev,& + & d_mat_set_sync + + + + class(psb_d_base_sparse_mat), allocatable, target, & + & save, private :: psb_d_base_mat_default + + interface psb_set_mat_default + module procedure psb_d_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_d_get_mat_default + end interface + + interface psb_sizeof + module procedure psb_d_sizeof + end interface + + + type :: psb_ldspmat_type + + class(psb_ld_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_ld_get_nrows + procedure, pass(a) :: get_ncols => psb_ld_get_ncols + procedure, pass(a) :: get_nzeros => psb_ld_get_nzeros + procedure, pass(a) :: get_nz_row => psb_ld_get_nz_row + procedure, pass(a) :: get_size => psb_ld_get_size + procedure, pass(a) :: get_dupl => psb_ld_get_dupl + procedure, pass(a) :: is_null => psb_ld_is_null + procedure, pass(a) :: is_bld => psb_ld_is_bld + procedure, pass(a) :: is_upd => psb_ld_is_upd + procedure, pass(a) :: is_asb => psb_ld_is_asb + procedure, pass(a) :: is_sorted => psb_ld_is_sorted + procedure, pass(a) :: is_by_rows => psb_ld_is_by_rows + procedure, pass(a) :: is_by_cols => psb_ld_is_by_cols + procedure, pass(a) :: is_upper => psb_ld_is_upper + procedure, pass(a) :: is_lower => psb_ld_is_lower + procedure, pass(a) :: is_triangle => psb_ld_is_triangle + procedure, pass(a) :: is_unit => psb_ld_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_ld_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_ld_get_fmt + procedure, pass(a) :: sizeof => psb_ld_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_ld_set_nrows + procedure, pass(a) :: set_ncols => psb_ld_set_ncols + procedure, pass(a) :: set_dupl => psb_ld_set_dupl + procedure, pass(a) :: set_null => psb_ld_set_null + procedure, pass(a) :: set_bld => psb_ld_set_bld + procedure, pass(a) :: set_upd => psb_ld_set_upd + procedure, pass(a) :: set_asb => psb_ld_set_asb + procedure, pass(a) :: set_sorted => psb_ld_set_sorted + procedure, pass(a) :: set_upper => psb_ld_set_upper + procedure, pass(a) :: set_lower => psb_ld_set_lower + procedure, pass(a) :: set_triangle => psb_ld_set_triangle + procedure, pass(a) :: set_unit => psb_ld_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_ld_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_ld_csall + procedure, pass(a) :: free => psb_ld_free + procedure, pass(a) :: trim => psb_ld_trim + procedure, pass(a) :: csput_a => psb_ld_csput_a + procedure, pass(a) :: csput_v => psb_ld_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_ld_csgetptn + procedure, pass(a) :: csgetrow => psb_ld_csgetrow + procedure, pass(a) :: csgetblk => psb_ld_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: icsgetptn => psb_ld_icsgetptn + procedure, pass(a) :: icsgetrow => psb_ld_icsgetrow + generic, public :: csget => icsgetptn, icsgetrow +#endif + procedure, pass(a) :: tril => psb_ld_tril + procedure, pass(a) :: triu => psb_ld_triu + procedure, pass(a) :: m_csclip => psb_ld_csclip + procedure, pass(a) :: b_csclip => psb_ld_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_ld_clean_zeros + procedure, pass(a) :: reall => psb_ld_reallocate_nz + procedure, pass(a) :: get_neigh => psb_ld_get_neigh + procedure, pass(a) :: reinit => psb_ld_reinit + procedure, pass(a) :: print_i => psb_ld_sparse_print + procedure, pass(a) :: print_n => psb_ld_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_ld_mold + procedure, pass(a) :: asb => psb_ld_asb + procedure, pass(a) :: transp_1mat => psb_ld_transp_1mat + procedure, pass(a) :: transp_2mat => psb_ld_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_ld_transc_1mat + procedure, pass(a) :: transc_2mat => psb_ld_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => ld_mat_sync + procedure, pass(a) :: is_host => ld_mat_is_host + procedure, pass(a) :: is_dev => ld_mat_is_dev + procedure, pass(a) :: is_sync => ld_mat_is_sync + procedure, pass(a) :: set_host => ld_mat_set_host + procedure, pass(a) :: set_dev => ld_mat_set_dev + procedure, pass(a) :: set_sync => ld_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_ld_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_ld_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_ld_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_ld_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: cscnv_np => psb_ld_cscnv + procedure, pass(a) :: cscnv_ip => psb_ld_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_ld_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_ldspmat_clone + ! + ! To/from d + ! + procedure, pass(a) :: mv_from_ib => psb_ld_mv_from_ib + procedure, pass(a) :: mv_to_ib => psb_ld_mv_to_ib + procedure, pass(a) :: cp_from_ib => psb_ld_cp_from_ib + procedure, pass(a) :: cp_to_ib => psb_ld_cp_to_ib + procedure, pass(a) :: mv_from_i => psb_ld_mv_from_i + procedure, pass(a) :: mv_to_i => psb_ld_mv_to_i + procedure, pass(a) :: cp_from_i => psb_ld_cp_from_i + procedure, pass(a) :: cp_to_i => psb_ld_cp_to_i + generic, public :: mv_from => mv_from_ib, mv_from_i + generic, public :: mv_to => mv_to_ib, mv_to_i + generic, public :: cp_from => cp_from_ib, cp_from_i + generic, public :: cp_to => cp_to_ib, cp_to_i + + ! Computational routines + procedure, pass(a) :: get_diag => psb_ld_get_diag + procedure, pass(a) :: maxval => psb_ld_maxval + procedure, pass(a) :: spnmi => psb_ld_csnmi + procedure, pass(a) :: spnm1 => psb_ld_csnm1 + procedure, pass(a) :: rowsum => psb_ld_rowsum + procedure, pass(a) :: arwsum => psb_ld_arwsum + procedure, pass(a) :: colsum => psb_ld_colsum + procedure, pass(a) :: aclsum => psb_ld_aclsum + procedure, pass(a) :: scals => psb_ld_scals + procedure, pass(a) :: scalv => psb_ld_scal + generic, public :: scal => scals, scalv + + end type psb_ldspmat_type + + private :: psb_ld_get_nrows, psb_ld_get_ncols, & + & psb_ld_get_nzeros, psb_ld_get_size, & + & psb_ld_get_dupl, psb_ld_is_null, psb_ld_is_bld, & + & psb_ld_is_upd, psb_ld_is_asb, psb_ld_is_sorted, & + & psb_ld_is_by_rows, psb_ld_is_by_cols, psb_ld_is_upper, & + & psb_ld_is_lower, psb_ld_is_triangle, psb_ld_get_nz_row, & + & ld_mat_sync, ld_mat_is_host, ld_mat_is_dev, & + & ld_mat_is_sync, ld_mat_set_host, ld_mat_set_dev,& + & ld_mat_set_sync + + + + class(psb_ld_base_sparse_mat), allocatable, target, & + & save, private :: psb_ld_base_mat_default + + interface psb_set_mat_default + module procedure psb_ld_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_ld_get_mat_default + end interface + + + ! == =================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == =================================== + + + interface + subroutine psb_d_set_nrows(m,a) + import :: psb_ipk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: m + end subroutine psb_d_set_nrows + end interface + + interface + subroutine psb_d_set_ncols(n,a) + import :: psb_ipk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_d_set_ncols + end interface + + interface + subroutine psb_d_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_d_set_dupl + end interface + + interface + subroutine psb_d_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_set_null + end interface + + interface + subroutine psb_d_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_set_bld + end interface + + interface + subroutine psb_d_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_set_upd + end interface + + interface + subroutine psb_d_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_set_asb + end interface + + interface + subroutine psb_d_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_sorted + end interface + + interface + subroutine psb_d_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_triangle + end interface + + interface + subroutine psb_d_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_unit + end interface + + interface + subroutine psb_d_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_lower + end interface + + interface + subroutine psb_d_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_d_set_upper + end interface + + interface + subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_d_sparse_print + end interface + + interface + subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + character(len=*), intent(in) :: fname + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_d_n_sparse_print + end interface + + interface + subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n + integer(psb_ipk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: lev + end subroutine psb_d_get_neigh + end interface + + interface + subroutine psb_d_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: nz + end subroutine psb_d_csall + end interface + + interface + subroutine psb_d_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + integer(psb_ipk_), intent(in) :: nz + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_reallocate_nz + end interface + + interface + subroutine psb_d_free(a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_free + end interface + + interface + subroutine psb_d_trim(a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_trim + end interface + + interface + subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_d_csput_a + end interface + + + interface + subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_vect_mod, only : psb_d_vect_type + use psb_i_vect_mod, only : psb_i_vect_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + type(psb_d_vect_type), intent(inout) :: val + type(psb_i_vect_type), intent(inout) :: ia, ja + integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_d_csput_v + end interface + + interface + subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csgetptn + end interface + + interface + subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csgetrow + end interface + + interface + subroutine psb_d_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csgetblk + end interface + + interface + subroutine psb_d_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_dspmat_type), optional, intent(inout) :: u + end subroutine psb_d_tril + end interface + + interface + subroutine psb_d_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_dspmat_type), optional, intent(inout) :: l + end subroutine psb_d_triu + end interface + + + interface + subroutine psb_d_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_csclip + end interface + + interface + subroutine psb_d_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_coo_sparse_mat + class(psb_dspmat_type), intent(in) :: a + type(psb_d_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_d_b_csclip + end interface + + interface + subroutine psb_d_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_d_mold + end interface + + interface + subroutine psb_d_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_d_asb + end interface + + interface + subroutine psb_d_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_transp_1mat + end interface + + interface + subroutine psb_d_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: b + end subroutine psb_d_transp_2mat + end interface + + interface + subroutine psb_d_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + end subroutine psb_d_transc_1mat + end interface + + interface + subroutine psb_d_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: b + end subroutine psb_d_transc_2mat + end interface + + interface + subroutine psb_d_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_d_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_d_cscnv + end interface + + + interface + subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_d_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_d_cscnv_ip + end interface + + + interface + subroutine psb_d_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(in) :: a + class(psb_d_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_d_cscnv_base + end interface + + ! + ! Produce a version of the matrix with diagonal cut + ! out; passes through a COO buffer. + ! + interface + subroutine psb_d_clip_d(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + end subroutine psb_d_clip_d + end interface + + interface + subroutine psb_d_clip_d_ip(a,info) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + end subroutine psb_d_clip_d_ip + end interface + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_d_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + end subroutine psb_d_mv_from + end interface + + interface + subroutine psb_d_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(out) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + end subroutine psb_d_cp_from + end interface + + interface + subroutine psb_d_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + end subroutine psb_d_mv_to + end interface + + interface + subroutine psb_d_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_dspmat_type), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + end subroutine psb_d_cp_to + end interface + ! + ! Mixed type conversions + ! + interface + subroutine psb_d_mv_from_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_dspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_d_mv_from_lb + end interface + + interface + subroutine psb_d_cp_from_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_dspmat_type), intent(out) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + end subroutine psb_d_cp_from_lb + end interface + + interface + subroutine psb_d_mv_to_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_dspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_d_mv_to_lb + end interface + + interface + subroutine psb_d_cp_to_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_dspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_d_cp_to_lb + end interface + + interface + subroutine psb_d_mv_from_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ldspmat_type + class(psb_dspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + end subroutine psb_d_mv_from_l + end interface + + interface + subroutine psb_d_cp_from_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ldspmat_type + class(psb_dspmat_type), intent(out) :: a + class(psb_ldspmat_type), intent(in) :: b + end subroutine psb_d_cp_from_l + end interface + + interface + subroutine psb_d_mv_to_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ldspmat_type + class(psb_dspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + end subroutine psb_d_mv_to_l + end interface + + interface + subroutine psb_d_cp_to_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_ldspmat_type + class(psb_dspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + end subroutine psb_d_cp_to_l + end interface + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_dspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dspmat_type_move + end interface + + interface + subroutine psb_dspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dspmat_clone + end interface + + + + + ! == =================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + ! == =================================== + + interface psb_csmm + subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_csmm + subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_csmv + subroutine psb_d_csmv_vect(alpha,a,x,beta,y,info,trans) + use psb_d_vect_mod, only : psb_d_vect_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_d_vect_type), intent(inout) :: x + type(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_d_csmv_vect + end interface + + interface psb_cssm + subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + real(psb_dpk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_d_cssm + subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta, x(:) + real(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_d_cssv + subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) + use psb_d_vect_mod, only : psb_d_vect_type + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), intent(in) :: alpha, beta + type(psb_d_vect_type), intent(inout) :: x + type(psb_d_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + type(psb_d_vect_type), optional, intent(inout) :: d + end subroutine psb_d_cssv_vect + end interface + + interface + function psb_d_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_maxval + end interface + + interface + function psb_d_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_csnmi + end interface + + interface + function psb_d_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_d_csnm1 + end interface + + interface + function psb_d_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_d_rowsum + end interface + + interface + function psb_d_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_d_arwsum + end interface + + interface + function psb_d_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_d_colsum + end interface + + interface + function psb_d_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_d_aclsum + end interface + + interface + function psb_d_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_d_get_diag + end interface + + interface psb_scal + subroutine psb_d_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_d_scal + subroutine psb_d_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_ + class(psb_dspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_scals + end interface + + + ! == =================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == =================================== + + + interface + subroutine psb_ld_set_nrows(m,a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + end subroutine psb_ld_set_nrows + end interface + + interface + subroutine psb_ld_set_ncols(n,a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + end subroutine psb_ld_set_ncols + end interface + + interface + subroutine psb_ld_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_ld_set_dupl + end interface + + interface + subroutine psb_ld_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_set_null + end interface + + interface + subroutine psb_ld_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_set_bld + end interface + + interface + subroutine psb_ld_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_set_upd + end interface + + interface + subroutine psb_ld_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_set_asb + end interface + + interface + subroutine psb_ld_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_sorted + end interface + + interface + subroutine psb_ld_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_triangle + end interface + + interface + subroutine psb_ld_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_unit + end interface + + interface + subroutine psb_ld_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_lower + end interface + + interface + subroutine psb_ld_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ld_set_upper + end interface + + interface + subroutine psb_ld_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_sparse_print + end interface + + interface + subroutine psb_ld_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + character(len=*), intent(in) :: fname + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ld_n_sparse_print + end interface + + interface + subroutine psb_ld_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_ld_get_neigh + end interface + + interface + subroutine psb_ld_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ld_csall + end interface + + interface + subroutine psb_ld_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + integer(psb_lpk_), intent(in) :: nz + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_reallocate_nz + end interface + + interface + subroutine psb_ld_free(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_free + end interface + + interface + subroutine psb_ld_trim(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_trim + end interface + + interface + subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_csput_a + end interface + + + interface + subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_vect_mod, only : psb_d_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + type(psb_d_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ld_csput_v + end interface + + interface + subroutine psb_ld_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csgetptn + end interface + + interface + subroutine psb_ld_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csgetrow + end interface + + interface + subroutine psb_ld_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csgetblk + end interface + + interface + subroutine psb_ld_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ldspmat_type), optional, intent(inout) :: u + end subroutine psb_ld_tril + end interface + + interface + subroutine psb_ld_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ldspmat_type), optional, intent(inout) :: l + end subroutine psb_ld_triu + end interface + + + interface + subroutine psb_ld_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_csclip + end interface + + interface + subroutine psb_ld_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_coo_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + type(psb_ld_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ld_b_csclip + end interface + + interface + subroutine psb_ld_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_ld_mold + end interface + + interface + subroutine psb_ld_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_ld_asb + end interface + + interface + subroutine psb_ld_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_transp_1mat + end interface + + interface + subroutine psb_ld_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + end subroutine psb_ld_transp_2mat + end interface + + interface + subroutine psb_ld_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + end subroutine psb_ld_transc_1mat + end interface + + interface + subroutine psb_ld_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + end subroutine psb_ld_transc_2mat + end interface + + interface + subroutine psb_ld_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ld_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_ld_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_ld_cscnv + end interface + + + interface + subroutine psb_ld_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_ld_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_ld_cscnv_ip + end interface + + + interface + subroutine psb_ld_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_ld_cscnv_base + end interface + + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_ld_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_mv_from + end interface + + interface + subroutine psb_ld_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(out) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + end subroutine psb_ld_cp_from + end interface + + interface + subroutine psb_ld_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_mv_to + end interface + + interface + subroutine psb_ld_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_ld_base_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_cp_to + end interface + ! + ! Mixed type conversions + ! + interface + subroutine psb_ld_mv_from_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_mv_from_ib + end interface + + interface + subroutine psb_ld_cp_from_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_ldspmat_type), intent(out) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + end subroutine psb_ld_cp_from_ib + end interface + + interface + subroutine psb_ld_mv_to_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_ldspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_mv_to_ib + end interface + + interface + subroutine psb_ld_cp_to_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_d_base_sparse_mat + class(psb_ldspmat_type), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + end subroutine psb_ld_cp_to_ib + end interface + + interface + subroutine psb_ld_mv_from_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_dspmat_type + class(psb_ldspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + end subroutine psb_ld_mv_from_i + end interface + + interface + subroutine psb_ld_cp_from_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_dspmat_type + class(psb_ldspmat_type), intent(out) :: a + class(psb_dspmat_type), intent(in) :: b + end subroutine psb_ld_cp_from_i + end interface + + interface + subroutine psb_ld_mv_to_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_dspmat_type + class(psb_ldspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + end subroutine psb_ld_mv_to_i + end interface + + interface + subroutine psb_ld_cp_to_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_, psb_dspmat_type + class(psb_ldspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: b + end subroutine psb_ld_cp_to_i + end interface + + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_ldspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldspmat_type_move + end interface + + interface + subroutine psb_ldspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldspmat_clone + end interface + + + + interface + function psb_ld_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_get_diag + end interface + + interface psb_scal + subroutine psb_ld_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ld_scal + subroutine psb_ld_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ld_scals + end interface + + interface + function psb_ld_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_maxval + end interface + + interface + function psb_ld_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csnmi + end interface + + interface + function psb_ld_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_ld_csnm1 + end interface + + interface + function psb_ld_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_rowsum + end interface + + interface + function psb_ld_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_arwsum + end interface + + interface + function psb_ld_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_colsum + end interface + + interface + function psb_ld_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_ldspmat_type, psb_dpk_ + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ld_aclsum + end interface + +contains + + subroutine psb_d_set_mat_default(a) + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + + if (allocated(psb_d_base_mat_default)) then + deallocate(psb_d_base_mat_default) + end if + allocate(psb_d_base_mat_default, mold=a) + + end subroutine psb_d_set_mat_default + + function psb_d_get_mat_default(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + class(psb_d_base_sparse_mat), pointer :: res + + res => psb_d_get_base_mat_default() + + end function psb_d_get_mat_default + + + function psb_d_get_base_mat_default() result(res) + implicit none + class(psb_d_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_d_base_mat_default)) then + allocate(psb_d_csr_sparse_mat :: psb_d_base_mat_default) + end if + + res => psb_d_base_mat_default + + end function psb_d_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_d_sizeof(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_d_sizeof + + + function psb_d_get_fmt(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_d_get_fmt + + + function psb_d_get_dupl(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_d_get_dupl + + function psb_d_get_nrows(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_d_get_nrows + + function psb_d_get_ncols(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_d_get_ncols + + function psb_d_is_triangle(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_d_is_triangle + + function psb_d_is_unit(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_d_is_unit + + function psb_d_is_upper(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_d_is_upper + + function psb_d_is_lower(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_d_is_lower + + function psb_d_is_null(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_d_is_null + + function psb_d_is_bld(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_d_is_bld + + function psb_d_is_upd(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_d_is_upd + + function psb_d_is_asb(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_d_is_asb + + function psb_d_is_sorted(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_d_is_sorted + + function psb_d_is_by_rows(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_d_is_by_rows + + function psb_d_is_by_cols(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_d_is_by_cols + + + ! + subroutine d_mat_sync(a) + implicit none + class(psb_dspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine d_mat_sync + + ! + subroutine d_mat_set_host(a) + implicit none + class(psb_dspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine d_mat_set_host + + + ! + subroutine d_mat_set_dev(a) + implicit none + class(psb_dspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine d_mat_set_dev + + ! + subroutine d_mat_set_sync(a) + implicit none + class(psb_dspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine d_mat_set_sync + + ! + function d_mat_is_dev(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function d_mat_is_dev + + ! + function d_mat_is_host(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function d_mat_is_host + + ! + function d_mat_is_sync(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function d_mat_is_sync + + + function psb_d_is_repeatable_updates(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_d_is_repeatable_updates + + subroutine psb_d_set_repeatable_updates(a,val) + implicit none + class(psb_dspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_d_set_repeatable_updates + + + function psb_d_get_nzeros(a) result(res) + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_d_get_nzeros + + function psb_d_get_size(a) result(res) + + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_d_get_size + + + function psb_d_get_nz_row(idx,a) result(res) + implicit none + integer(psb_ipk_), intent(in) :: idx + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_d_get_nz_row + + subroutine psb_d_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_dspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_d_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_d_lcsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_d_lcsgetptn + + subroutine psb_d_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_dspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_d_lcsgetrow +#endif + + ! + ! ld methods + ! + + + subroutine psb_ld_set_mat_default(a) + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + + if (allocated(psb_ld_base_mat_default)) then + deallocate(psb_ld_base_mat_default) + end if + allocate(psb_ld_base_mat_default, mold=a) + + end subroutine psb_ld_set_mat_default + + function psb_ld_get_mat_default(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), pointer :: res + + res => psb_ld_get_base_mat_default() + + end function psb_ld_get_mat_default + + + function psb_ld_get_base_mat_default() result(res) + implicit none + class(psb_ld_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_ld_base_mat_default)) then + allocate(psb_ld_csr_sparse_mat :: psb_ld_base_mat_default) + end if + + res => psb_ld_base_mat_default + + end function psb_ld_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_ld_sizeof(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_ld_sizeof + + + function psb_ld_get_fmt(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_ld_get_fmt + + + function psb_ld_get_dupl(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_ld_get_dupl + + function psb_ld_get_nrows(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_ld_get_nrows + + function psb_ld_get_ncols(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_ld_get_ncols + + function psb_ld_is_triangle(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_ld_is_triangle + + function psb_ld_is_unit(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_ld_is_unit + + function psb_ld_is_upper(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_ld_is_upper + + function psb_ld_is_lower(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_ld_is_lower + + function psb_ld_is_null(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_ld_is_null + + function psb_ld_is_bld(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_ld_is_bld + + function psb_ld_is_upd(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_ld_is_upd + + function psb_ld_is_asb(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_ld_is_asb + + function psb_ld_is_sorted(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_ld_is_sorted + + function psb_ld_is_by_rows(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_ld_is_by_rows + + function psb_ld_is_by_cols(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_ld_is_by_cols + + + ! + subroutine ld_mat_sync(a) + implicit none + class(psb_ldspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine ld_mat_sync + + ! + subroutine ld_mat_set_host(a) + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine ld_mat_set_host + + + ! + subroutine ld_mat_set_dev(a) + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine ld_mat_set_dev + + ! + subroutine ld_mat_set_sync(a) + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine ld_mat_set_sync + + ! + function ld_mat_is_dev(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function ld_mat_is_dev + + ! + function ld_mat_is_host(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function ld_mat_is_host + + ! + function ld_mat_is_sync(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function ld_mat_is_sync + + + function psb_ld_is_repeatable_updates(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_ld_is_repeatable_updates + + subroutine psb_ld_set_repeatable_updates(a,val) + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_ld_set_repeatable_updates + + + function psb_ld_get_nzeros(a) result(res) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_ld_get_nzeros + + function psb_ld_get_size(a) result(res) + + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_ld_get_size + + + function psb_ld_get_nz_row(idx,a) result(res) + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_ld_get_nz_row + + subroutine psb_ld_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_ldspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_ld_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_ld_icsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_ld_icsgetptn + + subroutine psb_ld_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_ld_icsgetrow +#endif + +end module psb_d_mat_mod diff --git a/base/modules/serial/psb_d_mat_mod.f90 b/base/modules/serial/psb_d_mat_mod.f90 deleted file mode 100644 index 5e3ae7e9a..000000000 --- a/base/modules/serial/psb_d_mat_mod.f90 +++ /dev/null @@ -1,1296 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! package: psb_d_mat_mod -! -! This module contains the definition of the psb_d_sparse type which -! is a generic container for a sparse matrix and it is mostly meant to -! provide a mean of switching, at run-time, among different formats, -! potentially unknown at the library compile-time by adding a layer of -! indirection. This type encapsulates the psb_d_base_sparse_mat class -! inside another class which is the one visible to the user. -! Most methods of the psb_d_mat_mod simply call the methods of the -! encapsulated class. -! The exceptions are mainly cscnv and cp_from/cp_to; these provide -! the functionalities to have the encapsulated class change its -! type dynamically, and to extract/input an inner object. -! -! A sparse matrix has a state corresponding to its progression -! through the application life. -! In particular, computational methods can only be invoked when -! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the -! following state transition table. Associated with these states are -! the possible dynamic types of the inner matrix object. -! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method -!| ---------------------------------- -!| Null Build csall -!| Build Build csput -!| Build Assembled cscnv -!| Assembled Assembled cscnv -!| Assembled Update reinit -!| Update Update csput -!| Update Assembled cscnv -!| * unchanged reall -!| Assembled Null free -! - - -module psb_d_mat_mod - - use psb_d_base_mat_mod - use psb_d_csr_mat_mod, only : psb_d_csr_sparse_mat - use psb_d_csc_mat_mod, only : psb_d_csc_sparse_mat - - type :: psb_dspmat_type - - class(psb_d_base_sparse_mat), allocatable :: a - - contains - ! Getters - procedure, pass(a) :: get_nrows => psb_d_get_nrows - procedure, pass(a) :: get_ncols => psb_d_get_ncols - procedure, pass(a) :: get_nzeros => psb_d_get_nzeros - procedure, pass(a) :: get_nz_row => psb_d_get_nz_row - procedure, pass(a) :: get_size => psb_d_get_size - procedure, pass(a) :: get_dupl => psb_d_get_dupl - procedure, pass(a) :: is_null => psb_d_is_null - procedure, pass(a) :: is_bld => psb_d_is_bld - procedure, pass(a) :: is_upd => psb_d_is_upd - procedure, pass(a) :: is_asb => psb_d_is_asb - procedure, pass(a) :: is_sorted => psb_d_is_sorted - procedure, pass(a) :: is_by_rows => psb_d_is_by_rows - procedure, pass(a) :: is_by_cols => psb_d_is_by_cols - procedure, pass(a) :: is_upper => psb_d_is_upper - procedure, pass(a) :: is_lower => psb_d_is_lower - procedure, pass(a) :: is_triangle => psb_d_is_triangle - procedure, pass(a) :: is_unit => psb_d_is_unit - procedure, pass(a) :: is_repeatable_updates => psb_d_is_repeatable_updates - procedure, pass(a) :: get_fmt => psb_d_get_fmt - procedure, pass(a) :: sizeof => psb_d_sizeof - - ! Setters - procedure, pass(a) :: set_nrows => psb_d_set_nrows - procedure, pass(a) :: set_ncols => psb_d_set_ncols - procedure, pass(a) :: set_dupl => psb_d_set_dupl - procedure, pass(a) :: set_null => psb_d_set_null - procedure, pass(a) :: set_bld => psb_d_set_bld - procedure, pass(a) :: set_upd => psb_d_set_upd - procedure, pass(a) :: set_asb => psb_d_set_asb - procedure, pass(a) :: set_sorted => psb_d_set_sorted - procedure, pass(a) :: set_upper => psb_d_set_upper - procedure, pass(a) :: set_lower => psb_d_set_lower - procedure, pass(a) :: set_triangle => psb_d_set_triangle - procedure, pass(a) :: set_unit => psb_d_set_unit - procedure, pass(a) :: set_repeatable_updates => psb_d_set_repeatable_updates - - ! Memory/data management - procedure, pass(a) :: csall => psb_d_csall - procedure, pass(a) :: free => psb_d_free - procedure, pass(a) :: trim => psb_d_trim - procedure, pass(a) :: csput_a => psb_d_csput_a - procedure, pass(a) :: csput_v => psb_d_csput_v - generic, public :: csput => csput_a, csput_v - procedure, pass(a) :: csgetptn => psb_d_csgetptn - procedure, pass(a) :: csgetrow => psb_d_csgetrow - procedure, pass(a) :: csgetblk => psb_d_csgetblk - generic, public :: csget => csgetptn, csgetrow, csgetblk - procedure, pass(a) :: tril => psb_d_tril - procedure, pass(a) :: triu => psb_d_triu - procedure, pass(a) :: m_csclip => psb_d_csclip - procedure, pass(a) :: b_csclip => psb_d_b_csclip - generic, public :: csclip => b_csclip, m_csclip - procedure, pass(a) :: clean_zeros => psb_d_clean_zeros - procedure, pass(a) :: reall => psb_d_reallocate_nz - procedure, pass(a) :: get_neigh => psb_d_get_neigh - procedure, pass(a) :: reinit => psb_d_reinit - procedure, pass(a) :: print_i => psb_d_sparse_print - procedure, pass(a) :: print_n => psb_d_n_sparse_print - generic, public :: print => print_i, print_n - procedure, pass(a) :: mold => psb_d_mold - procedure, pass(a) :: asb => psb_d_asb - procedure, pass(a) :: transp_1mat => psb_d_transp_1mat - procedure, pass(a) :: transp_2mat => psb_d_transp_2mat - generic, public :: transp => transp_1mat, transp_2mat - procedure, pass(a) :: transc_1mat => psb_d_transc_1mat - procedure, pass(a) :: transc_2mat => psb_d_transc_2mat - generic, public :: transc => transc_1mat, transc_2mat - - ! - ! Sync: centerpiece of handling of external storage. - ! Any derived class having extra storage upon sync - ! will guarantee that both fortran/host side and - ! external side contain the same data. The base - ! version is only a placeholder. - ! - procedure, pass(a) :: sync => d_mat_sync - procedure, pass(a) :: is_host => d_mat_is_host - procedure, pass(a) :: is_dev => d_mat_is_dev - procedure, pass(a) :: is_sync => d_mat_is_sync - procedure, pass(a) :: set_host => d_mat_set_host - procedure, pass(a) :: set_dev => d_mat_set_dev - procedure, pass(a) :: set_sync => d_mat_set_sync - - - ! These are specific to this level of encapsulation. - procedure, pass(a) :: mv_from_b => psb_d_mv_from - generic, public :: mv_from => mv_from_b - procedure, pass(a) :: mv_to_b => psb_d_mv_to - generic, public :: mv_to => mv_to_b - procedure, pass(a) :: cp_from_b => psb_d_cp_from - generic, public :: cp_from => cp_from_b - procedure, pass(a) :: cp_to_b => psb_d_cp_to - generic, public :: cp_to => cp_to_b - procedure, pass(a) :: clip_d_ip => psb_d_clip_d_ip - procedure, pass(a) :: clip_d => psb_d_clip_d - generic, public :: clip_diag => clip_d_ip, clip_d - procedure, pass(a) :: cscnv_np => psb_d_cscnv - procedure, pass(a) :: cscnv_ip => psb_d_cscnv_ip - procedure, pass(a) :: cscnv_base => psb_d_cscnv_base - generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base - procedure, pass(a) :: clone => psb_dspmat_clone - - ! Computational routines - procedure, pass(a) :: get_diag => psb_d_get_diag - procedure, pass(a) :: maxval => psb_d_maxval - procedure, pass(a) :: spnmi => psb_d_csnmi - procedure, pass(a) :: spnm1 => psb_d_csnm1 - procedure, pass(a) :: rowsum => psb_d_rowsum - procedure, pass(a) :: arwsum => psb_d_arwsum - procedure, pass(a) :: colsum => psb_d_colsum - procedure, pass(a) :: aclsum => psb_d_aclsum - procedure, pass(a) :: csmv_v => psb_d_csmv_vect - procedure, pass(a) :: csmv => psb_d_csmv - procedure, pass(a) :: csmm => psb_d_csmm - generic, public :: spmm => csmm, csmv, csmv_v - procedure, pass(a) :: scals => psb_d_scals - procedure, pass(a) :: scalv => psb_d_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: cssv_v => psb_d_cssv_vect - procedure, pass(a) :: cssv => psb_d_cssv - procedure, pass(a) :: cssm => psb_d_cssm - generic, public :: spsm => cssm, cssv, cssv_v - - end type psb_dspmat_type - - private :: psb_d_get_nrows, psb_d_get_ncols, & - & psb_d_get_nzeros, psb_d_get_size, & - & psb_d_get_dupl, psb_d_is_null, psb_d_is_bld, & - & psb_d_is_upd, psb_d_is_asb, psb_d_is_sorted, & - & psb_d_is_by_rows, psb_d_is_by_cols, psb_d_is_upper, & - & psb_d_is_lower, psb_d_is_triangle, psb_d_get_nz_row, & - & d_mat_sync, d_mat_is_host, d_mat_is_dev, & - & d_mat_is_sync, d_mat_set_host, d_mat_set_dev,& - & d_mat_set_sync - - - - class(psb_d_base_sparse_mat), allocatable, target, & - & save, private :: psb_d_base_mat_default - - interface psb_set_mat_default - module procedure psb_d_set_mat_default - end interface - - interface psb_get_mat_default - module procedure psb_d_get_mat_default - end interface - - interface psb_sizeof - module procedure psb_d_sizeof - end interface - - - ! == =================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - ! == =================================== - - - interface - subroutine psb_d_set_nrows(m,a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: m - end subroutine psb_d_set_nrows - end interface - - interface - subroutine psb_d_set_ncols(n,a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_d_set_ncols - end interface - - interface - subroutine psb_d_set_dupl(n,a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_d_set_dupl - end interface - - interface - subroutine psb_d_set_null(a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_set_null - end interface - - interface - subroutine psb_d_set_bld(a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_set_bld - end interface - - interface - subroutine psb_d_set_upd(a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_set_upd - end interface - - interface - subroutine psb_d_set_asb(a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_set_asb - end interface - - interface - subroutine psb_d_set_sorted(a,val) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_d_set_sorted - end interface - - interface - subroutine psb_d_set_triangle(a,val) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_d_set_triangle - end interface - - interface - subroutine psb_d_set_unit(a,val) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_d_set_unit - end interface - - interface - subroutine psb_d_set_lower(a,val) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_d_set_lower - end interface - - interface - subroutine psb_d_set_upper(a,val) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_d_set_upper - end interface - - interface - subroutine psb_d_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_dspmat_type - integer(psb_ipk_), intent(in) :: iout - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_d_sparse_print - end interface - - interface - subroutine psb_d_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_dspmat_type - character(len=*), intent(in) :: fname - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_d_n_sparse_print - end interface - - interface - subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n - integer(psb_ipk_), allocatable, intent(out) :: neigh(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev - end subroutine psb_d_get_neigh - end interface - - interface - subroutine psb_d_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nr,nc - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: nz - end subroutine psb_d_csall - end interface - - interface - subroutine psb_d_reallocate_nz(nz,a) - import :: psb_ipk_, psb_dspmat_type - integer(psb_ipk_), intent(in) :: nz - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_reallocate_nz - end interface - - interface - subroutine psb_d_free(a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_free - end interface - - interface - subroutine psb_d_trim(a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_trim - end interface - - interface - subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_d_csput_a - end interface - - - interface - subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_d_vect_mod, only : psb_d_vect_type - use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - type(psb_d_vect_type), intent(inout) :: val - type(psb_i_vect_type), intent(inout) :: ia, ja - integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_d_csput_v - end interface - - interface - subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_d_csgetptn - end interface - - interface - subroutine psb_d_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale,chksz - end subroutine psb_d_csgetrow - end interface - - interface - subroutine psb_d_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - class(psb_dspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_d_csgetblk - end interface - - interface - subroutine psb_d_tril(a,l,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - class(psb_dspmat_type), intent(inout) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_dspmat_type), optional, intent(inout) :: u - end subroutine psb_d_tril - end interface - - interface - subroutine psb_d_triu(a,u,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - class(psb_dspmat_type), intent(inout) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_dspmat_type), optional, intent(inout) :: l - end subroutine psb_d_triu - end interface - - - interface - subroutine psb_d_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - class(psb_dspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_d_csclip - end interface - - interface - subroutine psb_d_b_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_coo_sparse_mat - class(psb_dspmat_type), intent(in) :: a - type(psb_d_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_d_b_csclip - end interface - - interface - subroutine psb_d_mold(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(inout) :: a - class(psb_d_base_sparse_mat), allocatable, intent(out) :: b - end subroutine psb_d_mold - end interface - - interface - subroutine psb_d_asb(a,mold) - import :: psb_ipk_, psb_dspmat_type, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(inout) :: a - class(psb_d_base_sparse_mat), optional, intent(in) :: mold - end subroutine psb_d_asb - end interface - - interface - subroutine psb_d_transp_1mat(a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_transp_1mat - end interface - - interface - subroutine psb_d_transp_2mat(a,b) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(in) :: a - class(psb_dspmat_type), intent(inout) :: b - end subroutine psb_d_transp_2mat - end interface - - interface - subroutine psb_d_transc_1mat(a) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - end subroutine psb_d_transc_1mat - end interface - - interface - subroutine psb_d_transc_2mat(a,b) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(in) :: a - class(psb_dspmat_type), intent(inout) :: b - end subroutine psb_d_transc_2mat - end interface - - interface - subroutine psb_d_reinit(a,clear) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_d_reinit - - end interface - - - ! - ! These methods are specific to the outer SPMAT_TYPE level, since - ! they tamper with the inner BASE_SPARSE_MAT object. - ! - ! - - ! - ! CSCNV: switches to a different internal derived type. - ! 3 versions: copying to target - ! copying to a base_sparse_mat object. - ! in place - ! - ! - interface - subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(in) :: a - class(psb_dspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_d_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_d_cscnv - end interface - - - interface - subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(out) :: iinfo - integer(psb_ipk_),optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_d_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_d_cscnv_ip - end interface - - - interface - subroutine psb_d_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl - end subroutine psb_d_cscnv_base - end interface - - ! - ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. - ! - interface - subroutine psb_d_clip_d(a,b,info) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(in) :: a - class(psb_dspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - end subroutine psb_d_clip_d - end interface - - interface - subroutine psb_d_clip_d_ip(a,info) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info - end subroutine psb_d_clip_d_ip - end interface - - ! - ! These four interfaces cut through the - ! encapsulation between spmat_type and base_sparse_mat. - ! - interface - subroutine psb_d_mv_from(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - end subroutine psb_d_mv_from - end interface - - interface - subroutine psb_d_cp_from(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(out) :: a - class(psb_d_base_sparse_mat), intent(in) :: b - end subroutine psb_d_cp_from - end interface - - interface - subroutine psb_d_mv_to(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(inout) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - end subroutine psb_d_mv_to - end interface - - interface - subroutine psb_d_cp_to(a,b) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat - class(psb_dspmat_type), intent(in) :: a - class(psb_d_base_sparse_mat), intent(inout) :: b - end subroutine psb_d_cp_to - end interface - - ! - ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc - subroutine psb_dspmat_type_move(a,b,info) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - class(psb_dspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_dspmat_type_move - end interface - - interface - subroutine psb_dspmat_clone(a,b,info) - import :: psb_ipk_, psb_dspmat_type - class(psb_dspmat_type), intent(inout) :: a - class(psb_dspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_dspmat_clone - end interface - - - - - ! == =================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - ! == =================================== - - interface psb_csmm - subroutine psb_d_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_d_csmm - subroutine psb_d_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_d_csmv - subroutine psb_d_csmv_vect(alpha,a,x,beta,y,info,trans) - use psb_d_vect_mod, only : psb_d_vect_type - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_d_vect_type), intent(inout) :: x - type(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_d_csmv_vect - end interface - - interface psb_cssm - subroutine psb_d_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_d_cssm - subroutine psb_d_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta, x(:) - real(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_d_cssv - subroutine psb_d_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) - use psb_d_vect_mod, only : psb_d_vect_type - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(in) :: alpha, beta - type(psb_d_vect_type), intent(inout) :: x - type(psb_d_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - type(psb_d_vect_type), optional, intent(inout) :: d - end subroutine psb_d_cssv_vect - end interface - - interface - function psb_d_maxval(a) result(res) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_d_maxval - end interface - - interface - function psb_d_csnmi(a) result(res) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_d_csnmi - end interface - - interface - function psb_d_csnm1(a) result(res) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_d_csnm1 - end interface - - interface - function psb_d_rowsum(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_d_rowsum - end interface - - interface - function psb_d_arwsum(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_d_arwsum - end interface - - interface - function psb_d_colsum(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_d_colsum - end interface - - interface - function psb_d_aclsum(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_d_aclsum - end interface - - interface - function psb_d_get_diag(a,info) result(d) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_d_get_diag - end interface - - interface psb_scal - subroutine psb_d_scal(d,a,info,side) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(inout) :: a - real(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_d_scal - subroutine psb_d_scals(d,a,info) - import :: psb_ipk_, psb_dspmat_type, psb_dpk_ - class(psb_dspmat_type), intent(inout) :: a - real(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_d_scals - end interface - - -contains - - - - subroutine psb_d_set_mat_default(a) - implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - - if (allocated(psb_d_base_mat_default)) then - deallocate(psb_d_base_mat_default) - end if - allocate(psb_d_base_mat_default, mold=a) - - end subroutine psb_d_set_mat_default - - function psb_d_get_mat_default(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - class(psb_d_base_sparse_mat), pointer :: res - - res => psb_d_get_base_mat_default() - - end function psb_d_get_mat_default - - - function psb_d_get_base_mat_default() result(res) - implicit none - class(psb_d_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_d_base_mat_default)) then - allocate(psb_d_csr_sparse_mat :: psb_d_base_mat_default) - end if - - res => psb_d_base_mat_default - - end function psb_d_get_base_mat_default - - - - - ! == =================================== - ! - ! - ! - ! Getters - ! - ! - ! - ! - ! - ! == =================================== - - - function psb_d_sizeof(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - integer(psb_long_int_k_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_d_sizeof - - - function psb_d_get_fmt(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - character(len=5) :: res - - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' - end if - - end function psb_d_get_fmt - - - function psb_d_get_dupl(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_dupl() - else - res = psb_invalid_ - end if - end function psb_d_get_dupl - - function psb_d_get_nrows(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_nrows() - else - res = 0 - end if - - end function psb_d_get_nrows - - function psb_d_get_ncols(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_ncols() - else - res = 0 - end if - - end function psb_d_get_ncols - - function psb_d_is_triangle(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_triangle() - else - res = .false. - end if - - end function psb_d_is_triangle - - function psb_d_is_unit(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_unit() - else - res = .false. - end if - - end function psb_d_is_unit - - function psb_d_is_upper(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upper() - else - res = .false. - end if - - end function psb_d_is_upper - - function psb_d_is_lower(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = .not. a%a%is_upper() - else - res = .false. - end if - - end function psb_d_is_lower - - function psb_d_is_null(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_null() - else - res = .true. - end if - - end function psb_d_is_null - - function psb_d_is_bld(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_bld() - else - res = .false. - end if - - end function psb_d_is_bld - - function psb_d_is_upd(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upd() - else - res = .false. - end if - - end function psb_d_is_upd - - function psb_d_is_asb(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_asb() - else - res = .false. - end if - - end function psb_d_is_asb - - function psb_d_is_sorted(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_sorted() - else - res = .false. - end if - - end function psb_d_is_sorted - - function psb_d_is_by_rows(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_rows() - else - res = .false. - end if - - end function psb_d_is_by_rows - - function psb_d_is_by_cols(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_cols() - else - res = .false. - end if - - end function psb_d_is_by_cols - - - ! - subroutine d_mat_sync(a) - implicit none - class(psb_dspmat_type), target, intent(in) :: a - - if (allocated(a%a)) call a%a%sync() - - end subroutine d_mat_sync - - ! - subroutine d_mat_set_host(a) - implicit none - class(psb_dspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_host() - - end subroutine d_mat_set_host - - - ! - subroutine d_mat_set_dev(a) - implicit none - class(psb_dspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_dev() - - end subroutine d_mat_set_dev - - ! - subroutine d_mat_set_sync(a) - implicit none - class(psb_dspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_sync() - - end subroutine d_mat_set_sync - - ! - function d_mat_is_dev(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_dev() - else - res = .false. - end if - end function d_mat_is_dev - - ! - function d_mat_is_host(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_host() - else - res = .true. - end if - end function d_mat_is_host - - ! - function d_mat_is_sync(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_sync() - else - res = .true. - end if - - end function d_mat_is_sync - - - function psb_d_is_repeatable_updates(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_repeatable_updates() - else - res = .false. - end if - - end function psb_d_is_repeatable_updates - - subroutine psb_d_set_repeatable_updates(a,val) - implicit none - class(psb_dspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - - if (allocated(a%a)) then - call a%a%set_repeatable_updates(val) - end if - - end subroutine psb_d_set_repeatable_updates - - - function psb_d_get_nzeros(a) result(res) - implicit none - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%get_nzeros() - end if - - end function psb_d_get_nzeros - - function psb_d_get_size(a) result(res) - - implicit none - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - - res = 0 - if (allocated(a%a)) then - res = a%a%get_size() - end if - - end function psb_d_get_size - - - function psb_d_get_nz_row(idx,a) result(res) - implicit none - integer(psb_ipk_), intent(in) :: idx - class(psb_dspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - - if (allocated(a%a)) res = a%a%get_nz_row(idx) - - end function psb_d_get_nz_row - - subroutine psb_d_clean_zeros(a,info) - implicit none - integer(psb_ipk_), intent(out) :: info - class(psb_dspmat_type), intent(inout) :: a - - info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) - - end subroutine psb_d_clean_zeros - - -end module psb_d_mat_mod diff --git a/base/modules/serial/psb_d_serial_mod.f90 b/base/modules/serial/psb_d_serial_mod.f90 index b09260909..e43be2acd 100644 --- a/base/modules/serial/psb_d_serial_mod.f90 +++ b/base/modules/serial/psb_d_serial_mod.f90 @@ -119,9 +119,9 @@ module psb_d_serial_mod use psb_d_mat_mod, only : psb_dspmat_type import :: psb_ipk_ implicit none - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr type(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info type(psb_dspmat_type), intent(in), optional :: b logical,intent(in), optional :: rowscale end subroutine psb_drwextd @@ -129,12 +129,32 @@ module psb_d_serial_mod use psb_d_mat_mod, only : psb_d_base_sparse_mat import :: psb_ipk_ implicit none - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr class(psb_d_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info class(psb_d_base_sparse_mat), intent(in), optional :: b logical,intent(in), optional :: rowscale end subroutine psb_dbase_rwextd + subroutine psb_ldrwextd(nr,a,info,b,rowscale) + use psb_d_mat_mod, only : psb_ldspmat_type + import :: psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: nr + type(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + type(psb_ldspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + end subroutine psb_ldrwextd + subroutine psb_ldbase_rwextd(nr,a,info,b,rowscale) + use psb_d_mat_mod, only : psb_ld_base_sparse_mat + import :: psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: nr + class(psb_ld_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + class(psb_ld_base_sparse_mat), intent(in), optional :: b + logical,intent(in), optional :: rowscale + end subroutine psb_ldbase_rwextd end interface psb_rwextd @@ -203,6 +223,69 @@ module psb_d_serial_mod end subroutine psb_d_aspxpby end interface psb_aspxpby + interface psb_spspmm + subroutine psb_ldspspmm(a,b,c,info) + use psb_d_mat_mod, only : psb_ldspmat_type + import :: psb_ipk_ + implicit none + type(psb_ldspmat_type), intent(in) :: a,b + type(psb_ldspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldspspmm + subroutine psb_ldcsrspspmm(a,b,c,info) + use psb_d_mat_mod, only : psb_ld_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldcsrspspmm + subroutine psb_ldcscspspmm(a,b,c,info) + use psb_d_mat_mod, only : psb_ld_csc_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a,b + type(psb_ld_csc_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldcscspspmm + end interface psb_spspmm + + interface psb_symbmm + subroutine psb_ldsymbmm(a,b,c,info) + use psb_d_mat_mod, only : psb_ldspmat_type + import :: psb_ipk_ + implicit none + type(psb_ldspmat_type), intent(in) :: a,b + type(psb_ldspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldsymbmm + subroutine psb_ldbase_symbmm(a,b,c,info) + use psb_d_mat_mod, only : psb_ld_base_sparse_mat, psb_ld_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ldbase_symbmm + end interface psb_symbmm + + interface psb_numbmm + subroutine psb_ldnumbmm(a,b,c) + use psb_d_mat_mod, only : psb_ldspmat_type + import :: psb_ipk_ + implicit none + type(psb_ldspmat_type), intent(in) :: a,b + type(psb_ldspmat_type), intent(inout) :: c + end subroutine psb_ldnumbmm + subroutine psb_ldbase_numbmm(a,b,c) + use psb_d_mat_mod, only : psb_ld_base_sparse_mat, psb_ld_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(inout) :: c + end subroutine psb_ldbase_numbmm + end interface psb_numbmm + contains subroutine psb_dcsprt(iout,a,iv,head,ivr,ivc) diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 13b12d263..f6244e3ef 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -62,8 +62,9 @@ module psb_d_vect_mod procedure, pass(x) :: ins_v => d_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => d_vect_bld_x - procedure, pass(x) :: bld_n => d_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => d_vect_bld_mn + procedure, pass(x) :: bld_en => d_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => d_vect_get_vect procedure, pass(x) :: cnv => d_vect_cnv procedure, pass(x) :: set_scal => d_vect_set_scal @@ -112,7 +113,8 @@ module psb_d_vect_mod & d_vect_all, d_vect_reall, d_vect_zero, d_vect_asb, & & d_vect_gthab, d_vect_gthzv, d_vect_sctb, & & d_vect_free, d_vect_ins_a, d_vect_ins_v, d_vect_bld_x, & - & d_vect_bld_n, d_vect_get_vect, d_vect_cnv, d_vect_set_scal, & + & d_vect_bld_mn, d_vect_bld_en, d_vect_get_vect, & + & d_vect_cnv, d_vect_set_scal, & & d_vect_set_vect, d_vect_clone, d_vect_sync, d_vect_is_host, & & d_vect_is_dev, d_vect_is_sync, d_vect_set_host, & & d_vect_set_dev, d_vect_set_sync @@ -207,8 +209,8 @@ contains end subroutine d_vect_bld_x - subroutine d_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine d_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_d_vect_type), intent(inout) :: x class(psb_d_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -225,7 +227,28 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine d_vect_bld_n + end subroutine d_vect_bld_mn + + + subroutine d_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_d_vect_type), intent(inout) :: x + class(psb_d_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + + info = psb_success_ + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_d_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine d_vect_bld_en function d_vect_get_vect(x,n) result(res) class(psb_d_vect_type), intent(inout) :: x @@ -291,7 +314,7 @@ contains function d_vect_sizeof(x) result(res) implicit none class(psb_d_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function d_vect_sizeof @@ -1014,7 +1037,7 @@ contains function d_vect_sizeof(x) result(res) implicit none class(psb_d_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function d_vect_sizeof diff --git a/base/modules/serial/psb_i_base_vect_mod.f90 b/base/modules/serial/psb_i_base_vect_mod.f90 index 951df14b5..c18909312 100644 --- a/base/modules/serial/psb_i_base_vect_mod.f90 +++ b/base/modules/serial/psb_i_base_vect_mod.f90 @@ -62,14 +62,15 @@ module psb_i_base_vect_mod !> Values. integer(psb_ipk_), allocatable :: v(:) integer(psb_ipk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators ! procedure, pass(x) :: bld_x => i_base_bld_x - procedure, pass(x) :: bld_n => i_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => i_base_bld_mn + procedure, pass(x) :: bld_en => i_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => i_base_all procedure, pass(x) :: mold => i_base_mold ! @@ -81,7 +82,9 @@ module psb_i_base_vect_mod procedure, pass(x) :: ins_v => i_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => i_base_zero - procedure, pass(x) :: asb => i_base_asb + procedure, pass(x) :: asb_m => i_base_asb_m + procedure, pass(x) :: asb_e => i_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => i_base_free ! ! Sync: centerpiece of handling of external storage. @@ -209,22 +212,39 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_i_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine i_base_bld_n(x,n) + subroutine i_base_bld_mn(x,n) use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine i_base_bld_n + end subroutine i_base_bld_mn + + !> Function bld_en: + !! \memberof psb_i_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine i_base_bld_en(x,n) + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine i_base_bld_en !> Function base_all: !! \memberof psb_i_base_vect_type @@ -406,11 +426,11 @@ contains !! ! - subroutine i_base_asb(n, x, info) + subroutine i_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_i_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -420,7 +440,37 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine i_base_asb + end subroutine i_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_i_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine i_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_i_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine i_base_asb_e ! !> Function base_free: @@ -631,10 +681,10 @@ contains function i_base_sizeof(x) result(res) implicit none class(psb_i_base_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() end function i_base_sizeof @@ -722,7 +772,6 @@ contains integer(psb_ipk_) :: info, first_, last_, nr - first_ = 1 if (present(first)) first_ = max(1,first) last_ = min(psb_size(x%v),first_+size(val)-1) @@ -954,7 +1003,7 @@ module psb_i_base_multivect_mod !> Values. integer(psb_ipk_), allocatable :: v(:,:) integer(psb_ipk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1439,10 +1488,10 @@ contains function i_base_mlv_sizeof(x) result(res) implicit none class(psb_i_base_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() end function i_base_mlv_sizeof diff --git a/base/modules/serial/psb_i_vect_mod.F90 b/base/modules/serial/psb_i_vect_mod.F90 index 1e75d6733..0661fbe00 100644 --- a/base/modules/serial/psb_i_vect_mod.F90 +++ b/base/modules/serial/psb_i_vect_mod.F90 @@ -61,8 +61,9 @@ module psb_i_vect_mod procedure, pass(x) :: ins_v => i_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => i_vect_bld_x - procedure, pass(x) :: bld_n => i_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => i_vect_bld_mn + procedure, pass(x) :: bld_en => i_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => i_vect_get_vect procedure, pass(x) :: cnv => i_vect_cnv procedure, pass(x) :: set_scal => i_vect_set_scal @@ -90,7 +91,8 @@ module psb_i_vect_mod & i_vect_all, i_vect_reall, i_vect_zero, i_vect_asb, & & i_vect_gthab, i_vect_gthzv, i_vect_sctb, & & i_vect_free, i_vect_ins_a, i_vect_ins_v, i_vect_bld_x, & - & i_vect_bld_n, i_vect_get_vect, i_vect_cnv, i_vect_set_scal, & + & i_vect_bld_mn, i_vect_bld_en, i_vect_get_vect, & + & i_vect_cnv, i_vect_set_scal, & & i_vect_set_vect, i_vect_clone, i_vect_sync, i_vect_is_host, & & i_vect_is_dev, i_vect_is_sync, i_vect_set_host, & & i_vect_set_dev, i_vect_set_sync @@ -180,8 +182,8 @@ contains end subroutine i_vect_bld_x - subroutine i_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine i_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_i_vect_type), intent(inout) :: x class(psb_i_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -198,7 +200,28 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine i_vect_bld_n + end subroutine i_vect_bld_mn + + + subroutine i_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_i_vect_type), intent(inout) :: x + class(psb_i_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + + info = psb_success_ + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_i_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine i_vect_bld_en function i_vect_get_vect(x,n) result(res) class(psb_i_vect_type), intent(inout) :: x @@ -264,7 +287,7 @@ contains function i_vect_sizeof(x) result(res) implicit none class(psb_i_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function i_vect_sizeof @@ -743,7 +766,7 @@ contains function i_vect_sizeof(x) result(res) implicit none class(psb_i_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function i_vect_sizeof diff --git a/base/modules/serial/psb_l_base_vect_mod.f90 b/base/modules/serial/psb_l_base_vect_mod.f90 new file mode 100644 index 000000000..ab7b49f1f --- /dev/null +++ b/base/modules/serial/psb_l_base_vect_mod.f90 @@ -0,0 +1,1858 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_l_base_vect_mod +! +! This module contains the definition of the psb_l_base_vect type which +! is a container for dense vectors. +! This is encapsulated instead of being just a simple array to allow for +! more complicated situations, such as GPU programming, where the memory +! area we are interested in is not easily accessible from the host/Fortran +! side. It is also meant to be encapsulated in an outer type, to allow +! runtime switching as per the STATE design pattern, similar to the +! sparse matrix types. +! +! +module psb_l_base_vect_mod + + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_i_base_vect_mod + + !> \namespace psb_base_mod \class psb_l_base_vect_type + !! The psb_l_base_vect_type + !! defines a middle level integer(psb_lpk_) encapsulated dense vector. + !! The encapsulation is needed, in place of a simple array, to allow + !! for complicated situations, such as GPU programming, where the memory + !! area we are interested in is not easily accessible from the host/Fortran + !! side. It is also meant to be encapsulated in an outer type, to allow + !! runtime switching as per the STATE design pattern, similar to the + !! sparse matrix types. + !! + type psb_l_base_vect_type + !> Values. + integer(psb_lpk_), allocatable :: v(:) + integer(psb_lpk_), allocatable :: combuf(:) + integer(psb_mpk_), allocatable :: comid(:,:) + contains + ! + ! Constructors/allocators + ! + procedure, pass(x) :: bld_x => l_base_bld_x + procedure, pass(x) :: bld_mn => l_base_bld_mn + procedure, pass(x) :: bld_en => l_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en + procedure, pass(x) :: all => l_base_all + procedure, pass(x) :: mold => l_base_mold + ! + ! Insert/set. Assembly and free. + ! Assembly does almost nothing here, but is important + ! in derived classes. + ! + procedure, pass(x) :: ins_a => l_base_ins_a + procedure, pass(x) :: ins_v => l_base_ins_v + generic, public :: ins => ins_a, ins_v + procedure, pass(x) :: zero => l_base_zero + procedure, pass(x) :: asb_m => l_base_asb_m + procedure, pass(x) :: asb_e => l_base_asb_e + generic, public :: asb => asb_m, asb_e + procedure, pass(x) :: free => l_base_free + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(x) :: sync => l_base_sync + procedure, pass(x) :: is_host => l_base_is_host + procedure, pass(x) :: is_dev => l_base_is_dev + procedure, pass(x) :: is_sync => l_base_is_sync + procedure, pass(x) :: set_host => l_base_set_host + procedure, pass(x) :: set_dev => l_base_set_dev + procedure, pass(x) :: set_sync => l_base_set_sync + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => l_base_use_buffer + procedure, pass(x) :: new_buffer => l_base_new_buffer + procedure, nopass :: device_wait => l_base_device_wait + procedure, pass(x) :: maybe_free_buffer => l_base_maybe_free_buffer + procedure, pass(x) :: free_buffer => l_base_free_buffer + procedure, pass(x) :: new_comid => l_base_new_comid + procedure, pass(x) :: free_comid => l_base_free_comid + + ! + ! Basic info + procedure, pass(x) :: get_nrows => l_base_get_nrows + procedure, pass(x) :: sizeof => l_base_sizeof + procedure, nopass :: get_fmt => l_base_get_fmt + ! + ! Set/get data from/to an external array; also + ! overload assignment. + ! + procedure, pass(x) :: get_vect => l_base_get_vect + procedure, pass(x) :: set_scal => l_base_set_scal + procedure, pass(x) :: set_vect => l_base_set_vect + generic, public :: set => set_vect, set_scal + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! + procedure, pass(x) :: gthab => l_base_gthab + procedure, pass(x) :: gthzv => l_base_gthzv + procedure, pass(x) :: gthzv_x => l_base_gthzv_x + procedure, pass(x) :: gthzbuf => l_base_gthzbuf + generic, public :: gth => gthab, gthzv, gthzv_x, gthzbuf + procedure, pass(y) :: sctb => l_base_sctb + procedure, pass(y) :: sctb_x => l_base_sctb_x + procedure, pass(y) :: sctb_buf => l_base_sctb_buf + generic, public :: sct => sctb, sctb_x, sctb_buf + + + + end type psb_l_base_vect_type + + public :: psb_l_base_vect + private :: constructor, size_const + interface psb_l_base_vect + module procedure constructor, size_const + end interface psb_l_base_vect + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_lpk_) :: x(:) + type(psb_l_base_vect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_l_base_vect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(n,info) + + end function size_const + + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_l_base_vect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + subroutine l_base_bld_x(x,this) + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: this(:) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_vect_bld') + return + end if + x%v(:) = this(:) + + end subroutine l_base_bld_x + + ! + ! Create with size, but no initialization + ! + + !> Function bld_mn: + !! \memberof psb_l_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine l_base_bld_mn(x,n) + use psb_realloc_mod + implicit none + integer(psb_mpk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine l_base_bld_mn + + !> Function bld_en: + !! \memberof psb_l_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine l_base_bld_en(x,n) + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine l_base_bld_en + + !> Function base_all: + !! \memberof psb_l_base_vect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + subroutine l_base_all(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_l_base_vect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%v,info) + + end subroutine l_base_all + + !> Function base_mold: + !! \memberof psb_l_base_vect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + subroutine l_base_mold(x, y, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(in) :: x + class(psb_l_base_vect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_l_base_vect_type :: y, stat=info) + + end subroutine l_base_mold + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_ins: + !! \memberof psb_l_base_vect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + subroutine l_base_ins_a(n,irl,val,dupl,x,info) + use psi_serial_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i)) = x%v(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + call x%set_host() + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine l_base_ins_a + + subroutine l_base_ins_v(n,irl,val,dupl,x,info) + use psi_serial_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl + class(psb_i_base_vect_type), intent(inout) :: irl + class(psb_l_base_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (irl%is_dev()) call irl%sync() + if (val%is_dev()) call val%sync() + if (x%is_dev()) call x%sync() + call x%ins(n,irl%v,val%v,dupl,info) + + if (info /= 0) then + call psb_errpush(info,'base_vect_ins') + return + end if + + end subroutine l_base_ins_v + + + ! + !> Function base_zero + !! \memberof psb_l_base_vect_type + !! \brief Zero out contents + !! + ! + subroutine l_base_zero(x) + use psi_serial_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=lzero + call x%set_host() + end subroutine l_base_zero + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_l_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine l_base_asb_m(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_mpk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine l_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_l_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine l_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine l_base_asb_e + + ! + !> Function base_free: + !! \memberof psb_l_base_vect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + subroutine l_base_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info == 0) call x%free_buffer(info) + if (info == 0) call x%free_comid(info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine l_base_free + + + + ! + !> Function base_free_buffer: + !! \memberof psb_l_base_vect_type + !! \brief Free aux buffer + !! + !! \param info return code + !! + ! + subroutine l_base_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine l_base_free_buffer + + ! + !> Function base_maybe_free_buffer: + !! \memberof psb_l_base_vect_type + !! \brief Conditionally Free aux buffer. + !! In some derived classes, e.g. GPU, + !! does not really frees to avoid runtime + !! costs + !! + !! \param info return code + !! + ! + subroutine l_base_maybe_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine l_base_maybe_free_buffer + + ! + !> Function base_free_comid: + !! \memberof psb_l_base_vect_type + !! \brief Free aux MPI communication id buffer + !! + !! \param info return code + !! + ! + subroutine l_base_free_comid(x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine l_base_free_comid + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_sync: + !! \memberof psb_l_base_vect_type + !! \brief Sync: base version is a no-op. + !! + ! + subroutine l_base_sync(x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + + end subroutine l_base_sync + + ! + !> Function base_set_host: + !! \memberof psb_l_base_vect_type + !! \brief Set_host: base version is a no-op. + !! + ! + subroutine l_base_set_host(x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + + end subroutine l_base_set_host + + ! + !> Function base_set_dev: + !! \memberof psb_l_base_vect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + subroutine l_base_set_dev(x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + + end subroutine l_base_set_dev + + ! + !> Function base_set_sync: + !! \memberof psb_l_base_vect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + subroutine l_base_set_sync(x) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + + end subroutine l_base_set_sync + + ! + !> Function base_is_dev: + !! \memberof psb_l_base_vect_type + !! \brief Is vector on external device . + !! + ! + function l_base_is_dev(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + + res = .false. + end function l_base_is_dev + + ! + !> Function base_is_host + !! \memberof psb_l_base_vect_type + !! \brief Is vector on standard memory . + !! + ! + function l_base_is_host(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function l_base_is_host + + ! + !> Function base_is_sync + !! \memberof psb_l_base_vect_type + !! \brief Is vector on sync . + !! + ! + function l_base_is_sync(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + logical :: res + + res = .true. + end function l_base_is_sync + + + ! + ! Size info. + ! + ! + !> Function base_get_nrows + !! \memberof psb_l_base_vect_type + !! \brief Number of entries + !! + ! + function l_base_get_nrows(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v) + + end function l_base_get_nrows + + ! + !> Function base_get_sizeof + !! \memberof psb_l_base_vect_type + !! \brief Size in bytes + !! + ! + function l_base_sizeof(x) result(res) + implicit none + class(psb_l_base_vect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_lp) * x%get_nrows() + + end function l_base_sizeof + + ! + !> Function base_get_fmt + !! \memberof psb_l_base_vect_type + !! \brief Format + !! + ! + function l_base_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'BASE' + end function l_base_get_fmt + + + ! + ! + ! + !> Function base_get_vect + !! \memberof psb_l_base_vect_type + !! \brief Extract a copy of the contents + !! + ! + function l_base_get_vect(x,n) result(res) + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + ! Local variables + integer(psb_ipk_) :: isz + + if (.not.allocated(x%v)) return + if (.not.x%is_host()) call x%sync() + isz = x%get_nrows() + if (present(n)) isz = max(0,min(isz,n)) + allocate(res(isz),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_get_vect') + return + end if + res(1:isz) = x%v(1:isz) + end function l_base_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_set_scal + !! \memberof psb_l_base_vect_type + !! \brief Set all entries + !! \param val The value to set + !! + subroutine l_base_set_scal(x,val,first,last) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info, first_, last_ + + first_=1 + last_=size(x%v) + if (present(first)) first_ = max(1,first) + if (present(last)) last_ = min(last,last_) + + if (x%is_dev()) call x%sync() + x%v(first_:last_) = val + call x%set_host() + + end subroutine l_base_set_scal + + + ! + !> Function base_set_vect + !! \memberof psb_l_base_vect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + subroutine l_base_set_vect(x,val,first,last) + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info, first_, last_, nr + + first_ = 1 + if (present(first)) first_ = max(1,first) + last_ = min(psb_size(x%v),first_+size(val)-1) + if (present(last)) last_ = min(last,last_) + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(first_:last_) = val(1:last_-first_+1) + else + x%v = val + end if + call x%set_host() + + end subroutine l_base_set_vect + + + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_gthab + !! \memberof psb_l_base_vect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + subroutine l_base_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,alpha,x%v,beta,y) + + end subroutine l_base_gthab + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_l_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine l_base_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: y(:) + class(psb_l_base_vect_type) :: x + + if (idx%is_dev()) call idx%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine l_base_gthzv_x + + ! + ! New comm internals impl. + ! + subroutine l_base_gthzbuf(i,n,idx,x) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + class(psb_l_base_vect_type) :: x + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),x%combuf(i:)) + + end subroutine l_base_gthzbuf + ! + !> Function base_device_wait: + !! \memberof psb_l_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine l_base_device_wait() + implicit none + + end subroutine l_base_device_wait + + function l_base_use_buffer() result(res) + logical :: res + + res = .true. + end function l_base_use_buffer + + subroutine l_base_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,x%combuf,info) + end subroutine l_base_new_buffer + + subroutine l_base_new_comid(n,x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine l_base_new_comid + + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_gthzv + !! \memberof psb_l_base_vect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine l_base_gthzv(n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_base_vect_type) :: x + + if (x%is_dev()) call x%sync() + call psi_gth(n,idx,x%v,y) + + end subroutine l_base_gthzv + + ! + ! Scatter: + ! Y(IDX(:)) = beta*Y(IDX(:)) + X(:) + ! + ! + !> Function base_sctb + !! \memberof psb_l_base_vect_type + !! \brief scatter into a class(base_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + subroutine l_base_sctb(n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_base_vect_type) :: y + + if (y%is_dev()) call y%sync() + call psi_sct(n,idx,x,beta,y%v) + call y%set_host() + + end subroutine l_base_sctb + + subroutine l_base_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta, x(:) + class(psb_l_base_vect_type) :: y + + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),x,beta) + call y%set_host() + + end subroutine l_base_sctb_x + + subroutine l_base_sctb_buf(i,n,idx,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta + class(psb_l_base_vect_type) :: y + + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + call y%sct(n,idx%v(i:),y%combuf(i:),beta) + call y%set_host() + + end subroutine l_base_sctb_buf + +end module psb_l_base_vect_mod + + + + + +module psb_l_base_multivect_mod + + use psb_const_mod + use psb_error_mod + use psb_realloc_mod + use psb_l_base_vect_mod + + !> \namespace psb_base_mod \class psb_l_base_vect_type + !! The psb_l_base_vect_type + !! defines a middle level integer(psb_ipk_) encapsulated dense vector. + !! The encapsulation is needed, in place of a simple array, to allow + !! for complicated situations, such as GPU programming, where the memory + !! area we are interested in is not easily accessible from the host/Fortran + !! side. It is also meant to be encapsulated in an outer type, to allow + !! runtime switching as per the STATE design pattern, similar to the + !! sparse matrix types. + !! + private + public :: psb_l_base_multivect, psb_l_base_multivect_type + + type psb_l_base_multivect_type + !> Values. + integer(psb_lpk_), allocatable :: v(:,:) + integer(psb_lpk_), allocatable :: combuf(:) + integer(psb_mpk_), allocatable :: comid(:,:) + contains + ! + ! Constructors/allocators + ! + procedure, pass(x) :: bld_x => l_base_mlv_bld_x + procedure, pass(x) :: bld_n => l_base_mlv_bld_n + generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: all => l_base_mlv_all + procedure, pass(x) :: mold => l_base_mlv_mold + ! + ! Insert/set. Assembly and free. + ! Assembly does almost nothing here, but is important + ! in derived classes. + ! + procedure, pass(x) :: ins => l_base_mlv_ins + procedure, pass(x) :: zero => l_base_mlv_zero + procedure, pass(x) :: asb => l_base_mlv_asb + procedure, pass(x) :: free => l_base_mlv_free + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(x) :: sync => l_base_mlv_sync + procedure, pass(x) :: is_host => l_base_mlv_is_host + procedure, pass(x) :: is_dev => l_base_mlv_is_dev + procedure, pass(x) :: is_sync => l_base_mlv_is_sync + procedure, pass(x) :: set_host => l_base_mlv_set_host + procedure, pass(x) :: set_dev => l_base_mlv_set_dev + procedure, pass(x) :: set_sync => l_base_mlv_set_sync + + ! + ! Basic info + procedure, pass(x) :: get_nrows => l_base_mlv_get_nrows + procedure, pass(x) :: get_ncols => l_base_mlv_get_ncols + procedure, pass(x) :: sizeof => l_base_mlv_sizeof + procedure, nopass :: get_fmt => l_base_mlv_get_fmt + ! + ! Set/get data from/to an external array; also + ! overload assignment. + ! + procedure, pass(x) :: get_vect => l_base_mlv_get_vect + procedure, pass(x) :: set_scal => l_base_mlv_set_scal + procedure, pass(x) :: set_vect => l_base_mlv_set_vect + generic, public :: set => set_vect, set_scal + + + ! + ! These are for handling gather/scatter in new + ! comm internals implementation. + ! + procedure, nopass :: use_buffer => l_base_mlv_use_buffer + procedure, pass(x) :: new_buffer => l_base_mlv_new_buffer + procedure, nopass :: device_wait => l_base_mlv_device_wait + procedure, pass(x) :: maybe_free_buffer => l_base_mlv_maybe_free_buffer + procedure, pass(x) :: free_buffer => l_base_mlv_free_buffer + procedure, pass(x) :: new_comid => l_base_mlv_new_comid + procedure, pass(x) :: free_comid => l_base_mlv_free_comid + + ! + ! Gather/scatter. These are needed for MPI interfacing. + ! May have to be reworked. + ! + procedure, pass(x) :: gthab => l_base_mlv_gthab + procedure, pass(x) :: gthzv => l_base_mlv_gthzv + procedure, pass(x) :: gthzm => l_base_mlv_gthzm + procedure, pass(x) :: gthzv_x => l_base_mlv_gthzv_x + procedure, pass(x) :: gthzbuf => l_base_mlv_gthzbuf + generic, public :: gth => gthab, gthzv, gthzm, gthzv_x, gthzbuf + procedure, pass(y) :: sctb => l_base_mlv_sctb + procedure, pass(y) :: sctbr2 => l_base_mlv_sctbr2 + procedure, pass(y) :: sctb_x => l_base_mlv_sctb_x + procedure, pass(y) :: sctb_buf => l_base_mlv_sctb_buf + generic, public :: sct => sctb, sctbr2, sctb_x, sctb_buf + end type psb_l_base_multivect_type + + interface psb_l_base_multivect + module procedure constructor, size_const + end interface psb_l_base_multivect + +contains + + ! + ! Constructors. + ! + + !> Function constructor: + !! \brief Constructor from an array + !! \param x(:) input array to be copied + !! + function constructor(x) result(this) + integer(psb_lpk_) :: x(:,:) + type(psb_l_base_multivect_type) :: this + integer(psb_ipk_) :: info + + this%v = x + call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + end function constructor + + + !> Function constructor: + !! \brief Constructor from size + !! \param n Size of vector to be built. + !! + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_l_base_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%asb(m,n,info) + + end function size_const + + ! + ! Build from a sample + ! + + !> Function bld_x: + !! \memberof psb_l_base_multivect_type + !! \brief Build method from an array + !! \param x(:) input array to be copied + !! + subroutine l_base_mlv_bld_x(x,this) + use psb_realloc_mod + integer(psb_lpk_), intent(in) :: this(:,:) + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(size(this,1),size(this,2),x%v,info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_vect_bld') + return + end if + x%v(:,:) = this(:,:) + + end subroutine l_base_mlv_bld_x + + ! + ! Create with size, but no initialization + ! + + !> Function bld_n: + !! \memberof psb_l_base_multivect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine l_base_mlv_bld_n(x,m,n) + use psb_realloc_mod + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(m,n,x%v,info) + call x%asb(m,n,info) + + end subroutine l_base_mlv_bld_n + + !> Function base_mlv_all: + !! \memberof psb_l_base_multivect_type + !! \brief Build method with size (uninitialized data) and + !! allocation return code. + !! \param n size to be allocated. + !! \param info return code + !! + subroutine l_base_mlv_all(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_base_multivect_type), intent(out) :: x + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(m,n,x%v,info) + + end subroutine l_base_mlv_all + + !> Function base_mlv_mold: + !! \memberof psb_l_base_multivect_type + !! \brief Mold method: return a variable with the same dynamic type + !! \param y returned variable + !! \param info return code + !! + subroutine l_base_mlv_mold(x, y, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(in) :: x + class(psb_l_base_multivect_type), intent(out), allocatable :: y + integer(psb_ipk_), intent(out) :: info + + allocate(psb_l_base_multivect_type :: y, stat=info) + + end subroutine l_base_mlv_mold + + ! + ! Insert a bunch of values at specified positions. + ! + !> Function base_mlv_ins: + !! \memberof psb_l_base_multivect_type + !! \brief Insert coefficients. + !! + !! + !! Given a list of N pairs + !! (IRL(i),VAL(i)) + !! record a new coefficient in X such that + !! X(IRL(1:N)) = VAL(1:N). + !! + !! - the update operation will perform either + !! X(IRL(1:n)) = VAL(1:N) + !! or + !! X(IRL(1:n)) = X(IRL(1:n))+VAL(1:N) + !! according to the value of DUPLICATE. + !! + !! + !! \param n number of pairs in input + !! \param irl(:) the input row indices + !! \param val(:) the input coefficients + !! \param dupl how to treat duplicate entries + !! \param info return code + !! + ! + subroutine l_base_mlv_ins(n,irl,val,dupl,x,info) + use psi_serial_mod + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, isz + + info = 0 + if (psb_errstatus_fatal()) return + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + else if (n > min(size(irl),size(val))) then + info = psb_err_invalid_input_ + + else + isz = size(x%v,1) + select case(dupl) + case(psb_dupl_ovwrt_) + do i = 1, n + !loop over all val's rows + + ! row actual block row + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = val(i,:) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, n + !loop over all val's rows + if ((1 <= irl(i)).and.(irl(i) <= isz)) then + ! this row belongs to me + ! copy i-th row of block val in x + x%v(irl(i),:) = x%v(irl(i),:) + val(i,:) + end if + enddo + + case default + info = 321 + ! !$ call psb_errpush(info,name) + ! !$ goto 9999 + end select + end if + if (info /= 0) then + call psb_errpush(info,'base_mlv_vect_ins') + return + end if + + end subroutine l_base_mlv_ins + + ! + !> Function base_mlv_zero + !! \memberof psb_l_base_multivect_type + !! \brief Zero out contents + !! + ! + subroutine l_base_mlv_zero(x) + use psi_serial_mod + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + + if (allocated(x%v)) x%v=lzero + + end subroutine l_base_mlv_zero + + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_mlv_asb: + !! \memberof psb_l_base_multivect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine l_base_mlv_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if ((x%get_nrows() < m).or.(x%get_ncols() Function base_mlv_free: + !! \memberof psb_l_base_multivect_type + !! \brief Free vector + !! + !! \param info return code + !! + ! + subroutine l_base_mlv_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) deallocate(x%v, stat=info) + if (info /= 0) call & + & psb_errpush(psb_err_alloc_dealloc_,'vect_free') + + end subroutine l_base_mlv_free + + + + ! + ! The base version of SYNC & friends does nothing, it's just + ! a placeholder. + ! + ! + !> Function base_mlv_sync: + !! \memberof psb_l_base_multivect_type + !! \brief Sync: base version is a no-op. + !! + ! + subroutine l_base_mlv_sync(x) + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + + end subroutine l_base_mlv_sync + + ! + !> Function base_mlv_set_host: + !! \memberof psb_l_base_multivect_type + !! \brief Set_host: base version is a no-op. + !! + ! + subroutine l_base_mlv_set_host(x) + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + + end subroutine l_base_mlv_set_host + + ! + !> Function base_mlv_set_dev: + !! \memberof psb_l_base_multivect_type + !! \brief Set_dev: base version is a no-op. + !! + ! + subroutine l_base_mlv_set_dev(x) + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + + end subroutine l_base_mlv_set_dev + + ! + !> Function base_mlv_set_sync: + !! \memberof psb_l_base_multivect_type + !! \brief Set_sync: base version is a no-op. + !! + ! + subroutine l_base_mlv_set_sync(x) + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + + end subroutine l_base_mlv_set_sync + + ! + !> Function base_mlv_is_dev: + !! \memberof psb_l_base_multivect_type + !! \brief Is vector on external device . + !! + ! + function l_base_mlv_is_dev(x) result(res) + implicit none + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + + res = .false. + end function l_base_mlv_is_dev + + ! + !> Function base_mlv_is_host + !! \memberof psb_l_base_multivect_type + !! \brief Is vector on standard memory . + !! + ! + function l_base_mlv_is_host(x) result(res) + implicit none + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function l_base_mlv_is_host + + ! + !> Function base_mlv_is_sync + !! \memberof psb_l_base_multivect_type + !! \brief Is vector on sync . + !! + ! + function l_base_mlv_is_sync(x) result(res) + implicit none + class(psb_l_base_multivect_type), intent(in) :: x + logical :: res + + res = .true. + end function l_base_mlv_is_sync + + + ! + ! Size info. + ! + ! + !> Function base_mlv_get_nrows + !! \memberof psb_l_base_multivect_type + !! \brief Number of entries + !! + ! + function l_base_mlv_get_nrows(x) result(res) + implicit none + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,1) + + end function l_base_mlv_get_nrows + + function l_base_mlv_get_ncols(x) result(res) + implicit none + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + + res = 0 + if (allocated(x%v)) res = size(x%v,2) + + end function l_base_mlv_get_ncols + + ! + !> Function base_mlv_get_sizeof + !! \memberof psb_l_base_multivect_type + !! \brief Size in bytesa + !! + ! + function l_base_mlv_sizeof(x) result(res) + implicit none + class(psb_l_base_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + + ! Force 8-byte integers. + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() + + end function l_base_mlv_sizeof + + ! + !> Function base_mlv_get_fmt + !! \memberof psb_l_base_multivect_type + !! \brief Format + !! + ! + function l_base_mlv_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'BASE' + end function l_base_mlv_get_fmt + + + ! + ! + ! + !> Function base_mlv_get_vect + !! \memberof psb_l_base_multivect_type + !! \brief Extract a copy of the contents + !! + ! + function l_base_mlv_get_vect(x) result(res) + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info,m,n + m = x%get_nrows() + n = x%get_ncols() + if (.not.allocated(x%v)) return + call x%sync() + allocate(res(m,n),stat=info) + if (info /= 0) then + call psb_errpush(psb_err_alloc_dealloc_,'base_mlv_get_vect') + return + end if + res(1:m,1:n) = x%v(1:m,1:n) + end function l_base_mlv_get_vect + + ! + ! Reset all values + ! + ! + !> Function base_mlv_set_scal + !! \memberof psb_l_base_multivect_type + !! \brief Set all entries + !! \param val The value to set + !! + subroutine l_base_mlv_set_scal(x,val) + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + + integer(psb_ipk_) :: info + x%v = val + + end subroutine l_base_mlv_set_scal + + ! + !> Function base_mlv_set_vect + !! \memberof psb_l_base_multivect_type + !! \brief Set all entries + !! \param val(:) The vector to be copied in + !! + subroutine l_base_mlv_set_vect(x,val) + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_) :: nr, nc + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + nr = min(size(x%v,1),size(val,1)) + nc = min(size(x%v,2),size(val,2)) + + x%v(1:nr,1:nc) = val(1:nr,1:nc) + else + x%v = val + end if + + end subroutine l_base_mlv_set_vect + + + function l_base_mlv_use_buffer() result(res) + implicit none + logical :: res + + res = .true. + end function l_base_mlv_use_buffer + + subroutine l_base_mlv_new_buffer(n,x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: nc + nc = x%get_ncols() + call psb_realloc(n*nc,x%combuf,info) + end subroutine l_base_mlv_new_buffer + + subroutine l_base_mlv_new_comid(n,x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_), intent(out) :: info + + call psb_realloc(n,2_psb_ipk_,x%comid,info) + end subroutine l_base_mlv_new_comid + + + subroutine l_base_mlv_maybe_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + + info = 0 + if (psb_get_maybe_free_buffer())& + & call x%free_buffer(info) + + end subroutine l_base_mlv_maybe_free_buffer + + subroutine l_base_mlv_free_buffer(x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%combuf)) & + & deallocate(x%combuf,stat=info) + end subroutine l_base_mlv_free_buffer + + subroutine l_base_mlv_free_comid(x,info) + use psb_realloc_mod + implicit none + class(psb_l_base_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%comid)) & + & deallocate(x%comid,stat=info) + end subroutine l_base_mlv_free_comid + + + ! + ! Gather: Y = beta * Y + alpha * X(IDX(:)) + ! + ! + !> Function base_mlv_gthab + !! \memberof psb_l_base_multivect_type + !! \brief gather into an array + !! Y = beta * Y + alpha * X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param alpha + !! \param beta + subroutine l_base_mlv_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + call psi_gth(n,nc,idx,alpha,x%v,beta,y) + + end subroutine l_base_mlv_gthab + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_l_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine l_base_mlv_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: y(:) + class(psb_l_base_multivect_type) :: x + + if (x%is_dev()) call x%sync() + call x%gth(n,idx%v(i:),y) + + end subroutine l_base_mlv_gthzv_x + + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_l_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine l_base_mlv_gthzv(n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine l_base_mlv_gthzv + ! + ! shortcut alpha=1 beta=0 + ! + !> Function base_mlv_gthzv + !! \memberof psb_l_base_multivect_type + !! \brief gather into an array special alpha=1 beta=0 + !! Y = X(IDX(:)) + !! \param n how many entries to consider + !! \param idx(:) indices + subroutine l_base_mlv_gthzm(n,idx,x,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: y(:,:) + class(psb_l_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (x%is_dev()) call x%sync() + if (.not.allocated(x%v)) then + return + end if + nc = psb_size(x%v,2_psb_ipk_) + + call psi_gth(n,nc,idx,x%v,y) + + end subroutine l_base_mlv_gthzm + + ! + ! New comm internals impl. + ! + subroutine l_base_mlv_gthzbuf(i,ixb,n,idx,x) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i, ixb, n + class(psb_i_base_vect_type) :: idx + class(psb_l_base_multivect_type) :: x + integer(psb_ipk_) :: nc + + if (.not.allocated(x%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'gthzbuf') + return + end if + if (idx%is_dev()) call idx%sync() + if (x%is_dev()) call x%sync() + nc = x%get_ncols() + call x%gth(n,idx%v(i:),x%combuf(ixb:)) + + end subroutine l_base_mlv_gthzbuf + + ! + ! Scatter: + ! Y(IDX(:),:) = beta*Y(IDX(:),:) + X(:) + ! + ! + !> Function base_mlv_sctb + !! \memberof psb_l_base_multivect_type + !! \brief scatter into a class(base_mlv_vect) + !! Y(IDX(:)) = beta * Y(IDX(:)) + X(:) + !! \param n how many entries to consider + !! \param idx(:) indices + !! \param beta + !! \param x(:) + subroutine l_base_mlv_sctb(n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (y%is_dev()) call y%sync() + nc = psb_size(y%v,2_psb_ipk_) + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine l_base_mlv_sctb + + subroutine l_base_mlv_sctbr2(n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: beta, x(:,:) + class(psb_l_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (y%is_dev()) call y%sync() + nc = y%get_ncols() + call psi_sct(n,nc,idx,x,beta,y%v) + call y%set_host() + + end subroutine l_base_mlv_sctbr2 + + subroutine l_base_mlv_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + integer( psb_lpk_) :: beta, x(:) + class(psb_l_base_multivect_type) :: y + + call y%sct(n,idx%v(i:),x,beta) + + end subroutine l_base_mlv_sctb_x + + subroutine l_base_mlv_sctb_buf(i,iyb,n,idx,beta,y) + use psi_serial_mod + implicit none + integer(psb_ipk_) :: i, iyb, n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta + class(psb_l_base_multivect_type) :: y + integer(psb_ipk_) :: nc + + if (.not.allocated(y%combuf)) then + call psb_errpush(psb_err_alloc_dealloc_,'sctb_buf') + return + end if + if (y%is_dev()) call y%sync() + if (idx%is_dev()) call idx%sync() + nc = y%get_ncols() + call y%sct(n,idx%v(i:),y%combuf(iyb:),beta) + call y%set_host() + + end subroutine l_base_mlv_sctb_buf + + ! + !> Function base_device_wait: + !! \memberof psb_l_base_vect_type + !! \brief device_wait: base version is a no-op. + !! + ! + subroutine l_base_mlv_device_wait() + implicit none + + end subroutine l_base_mlv_device_wait + +end module psb_l_base_multivect_mod + diff --git a/base/modules/serial/psb_l_vect_mod.F90 b/base/modules/serial/psb_l_vect_mod.F90 new file mode 100644 index 000000000..5d0369d6d --- /dev/null +++ b/base/modules/serial/psb_l_vect_mod.F90 @@ -0,0 +1,964 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_l_vect_mod +! +! This module contains the definition of the psb_l_vect type which +! is the outer container for dense vectors. +! Therefore all methods simply invoke the corresponding methods of the +! inner component. +! +module psb_l_vect_mod + + use psb_l_base_vect_mod + use psb_i_vect_mod + + type psb_l_vect_type + class(psb_l_base_vect_type), allocatable :: v + contains + procedure, pass(x) :: get_nrows => l_vect_get_nrows + procedure, pass(x) :: sizeof => l_vect_sizeof + procedure, pass(x) :: get_fmt => l_vect_get_fmt + procedure, pass(x) :: all => l_vect_all + procedure, pass(x) :: reall => l_vect_reall + procedure, pass(x) :: zero => l_vect_zero + procedure, pass(x) :: asb => l_vect_asb + procedure, pass(x) :: gthab => l_vect_gthab + procedure, pass(x) :: gthzv => l_vect_gthzv + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => l_vect_sctb + generic, public :: sct => sctb + procedure, pass(x) :: free => l_vect_free + procedure, pass(x) :: ins_a => l_vect_ins_a + procedure, pass(x) :: ins_v => l_vect_ins_v + generic, public :: ins => ins_v, ins_a + procedure, pass(x) :: bld_x => l_vect_bld_x + procedure, pass(x) :: bld_mn => l_vect_bld_mn + procedure, pass(x) :: bld_en => l_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en + procedure, pass(x) :: get_vect => l_vect_get_vect + procedure, pass(x) :: cnv => l_vect_cnv + procedure, pass(x) :: set_scal => l_vect_set_scal + procedure, pass(x) :: set_vect => l_vect_set_vect + generic, public :: set => set_vect, set_scal + procedure, pass(x) :: clone => l_vect_clone + + procedure, pass(x) :: sync => l_vect_sync + procedure, pass(x) :: is_host => l_vect_is_host + procedure, pass(x) :: is_dev => l_vect_is_dev + procedure, pass(x) :: is_sync => l_vect_is_sync + procedure, pass(x) :: set_host => l_vect_set_host + procedure, pass(x) :: set_dev => l_vect_set_dev + procedure, pass(x) :: set_sync => l_vect_set_sync + + end type psb_l_vect_type + + public :: psb_l_vect + private :: constructor, size_const + interface psb_l_vect + module procedure constructor, size_const + end interface psb_l_vect + + private :: l_vect_get_nrows, l_vect_sizeof, l_vect_get_fmt, & + & l_vect_all, l_vect_reall, l_vect_zero, l_vect_asb, & + & l_vect_gthab, l_vect_gthzv, l_vect_sctb, & + & l_vect_free, l_vect_ins_a, l_vect_ins_v, l_vect_bld_x, & + & l_vect_bld_mn, l_vect_bld_en, l_vect_get_vect, & + & l_vect_cnv, l_vect_set_scal, & + & l_vect_set_vect, l_vect_clone, l_vect_sync, l_vect_is_host, & + & l_vect_is_dev, l_vect_is_sync, l_vect_set_host, & + & l_vect_set_dev, l_vect_set_sync + + + + class(psb_l_base_vect_type), allocatable, target,& + & save, private :: psb_l_base_vect_default + + interface psb_set_vect_default + module procedure psb_l_set_vect_default + end interface psb_set_vect_default + + interface psb_get_vect_default + module procedure psb_l_get_vect_default + end interface psb_get_vect_default + + +contains + + + subroutine psb_l_set_vect_default(v) + implicit none + class(psb_l_base_vect_type), intent(in) :: v + + if (allocated(psb_l_base_vect_default)) then + deallocate(psb_l_base_vect_default) + end if + allocate(psb_l_base_vect_default, mold=v) + + end subroutine psb_l_set_vect_default + + function psb_l_get_vect_default(v) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: v + class(psb_l_base_vect_type), pointer :: res + + res => psb_l_get_base_vect_default() + + end function psb_l_get_vect_default + + + function psb_l_get_base_vect_default() result(res) + implicit none + class(psb_l_base_vect_type), pointer :: res + + if (.not.allocated(psb_l_base_vect_default)) then + allocate(psb_l_base_vect_type :: psb_l_base_vect_default) + end if + + res => psb_l_base_vect_default + + end function psb_l_get_base_vect_default + + + subroutine l_vect_clone(x,y,info) + implicit none + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine l_vect_clone + + subroutine l_vect_bld_x(x,invect,mold) + integer(psb_lpk_), intent(in) :: invect(:) + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine l_vect_bld_x + + + subroutine l_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_l_base_vect_type), pointer :: mld + + info = psb_success_ + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine l_vect_bld_mn + + + subroutine l_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + + info = psb_success_ + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine l_vect_bld_en + + function l_vect_get_vect(x,n) result(res) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:) + integer(psb_ipk_) :: info + integer(psb_ipk_), optional :: n + + if (allocated(x%v)) then + res = x%v%get_vect(n) + end if + end function l_vect_get_vect + + subroutine l_vect_set_scal(x,val,first,last) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine l_vect_set_scal + + subroutine l_vect_set_vect(x,val,first,last) + class(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), optional :: first, last + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val,first,last) + + end subroutine l_vect_set_vect + + + function constructor(x) result(this) + integer(psb_lpk_) :: x(:) + type(psb_l_vect_type) :: this + integer(psb_ipk_) :: info + + call this%bld(x) + call this%asb(size(x,kind=psb_ipk_),info) + + end function constructor + + + function size_const(n) result(this) + integer(psb_ipk_), intent(in) :: n + type(psb_l_vect_type) :: this + integer(psb_ipk_) :: info + + call this%bld(n) + call this%asb(n,info) + + end function size_const + + function l_vect_get_nrows(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function l_vect_get_nrows + + function l_vect_sizeof(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function l_vect_sizeof + + function l_vect_get_fmt(x) result(res) + implicit none + class(psb_l_vect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function l_vect_get_fmt + + subroutine l_vect_all(n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_l_base_vect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine l_vect_all + + subroutine l_vect_reall(n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(n,info) + if (info == 0) & + & call x%asb(n,info) + + end subroutine l_vect_reall + + subroutine l_vect_zero(x) + use psi_serial_mod + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine l_vect_zero + + subroutine l_vect_asb(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: n + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(n,info) + + end subroutine l_vect_asb + + subroutine l_vect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine l_vect_gthab + + subroutine l_vect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_vect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine l_vect_gthzv + + subroutine l_vect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_vect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine l_vect_sctb + + subroutine l_vect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine l_vect_free + + subroutine l_vect_ins_a(n,irl,val,dupl,x,info) + use psi_serial_mod + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i + + info = 0 + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + return + end if + + call x%v%ins(n,irl,val,dupl,info) + + end subroutine l_vect_ins_a + + subroutine l_vect_ins_v(n,irl,val,dupl,x,info) + use psi_serial_mod + implicit none + class(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl + class(psb_i_vect_type), intent(inout) :: irl + class(psb_l_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i + + info = 0 + if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then + info = psb_err_invalid_vect_state_ + return + end if + + call x%v%ins(n,irl%v,val%v,dupl,info) + + end subroutine l_vect_ins_v + + + subroutine l_vect_cnv(x,mold) + class(psb_l_vect_type), intent(inout) :: x + class(psb_l_base_vect_type), intent(in), optional :: mold + class(psb_l_base_vect_type), allocatable :: tmp + + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info,mold=psb_l_get_base_vect_default()) + end if + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + + end subroutine l_vect_cnv + + + subroutine l_vect_sync(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine l_vect_sync + + subroutine l_vect_set_sync(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_sync() + + end subroutine l_vect_set_sync + + subroutine l_vect_set_host(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_host() + + end subroutine l_vect_set_host + + subroutine l_vect_set_dev(x) + implicit none + class(psb_l_vect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%set_dev() + + end subroutine l_vect_set_dev + + function l_vect_is_sync(x) result(res) + implicit none + logical :: res + class(psb_l_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_sync() + + end function l_vect_is_sync + + function l_vect_is_host(x) result(res) + implicit none + logical :: res + class(psb_l_vect_type), intent(inout) :: x + + res = .true. + if (allocated(x%v)) & + & res = x%v%is_host() + + end function l_vect_is_host + + function l_vect_is_dev(x) result(res) + implicit none + logical :: res + class(psb_l_vect_type), intent(inout) :: x + + res = .false. + if (allocated(x%v)) & + & res = x%v%is_dev() + + end function l_vect_is_dev + + +end module psb_l_vect_mod + + + +module psb_l_multivect_mod + + use psb_l_base_multivect_mod + use psb_const_mod + use psb_i_vect_mod + + + !private + + type psb_l_multivect_type + class(psb_l_base_multivect_type), allocatable :: v + contains + procedure, pass(x) :: get_nrows => l_vect_get_nrows + procedure, pass(x) :: get_ncols => l_vect_get_ncols + procedure, pass(x) :: sizeof => l_vect_sizeof + procedure, pass(x) :: get_fmt => l_vect_get_fmt + + procedure, pass(x) :: all => l_vect_all + procedure, pass(x) :: reall => l_vect_reall + procedure, pass(x) :: zero => l_vect_zero + procedure, pass(x) :: asb => l_vect_asb + procedure, pass(x) :: sync => l_vect_sync + procedure, pass(x) :: free => l_vect_free + procedure, pass(x) :: ins => l_vect_ins + procedure, pass(x) :: bld_x => l_vect_bld_x + procedure, pass(x) :: bld_n => l_vect_bld_n + generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: get_vect => l_vect_get_vect + procedure, pass(x) :: cnv => l_vect_cnv + procedure, pass(x) :: set_scal => l_vect_set_scal + procedure, pass(x) :: set_vect => l_vect_set_vect + generic, public :: set => set_vect, set_scal + procedure, pass(x) :: clone => l_vect_clone + procedure, pass(x) :: gthab => l_vect_gthab + procedure, pass(x) :: gthzv => l_vect_gthzv + procedure, pass(x) :: gthzv_x => l_vect_gthzv_x + generic, public :: gth => gthab, gthzv + procedure, pass(y) :: sctb => l_vect_sctb + procedure, pass(y) :: sctb_x => l_vect_sctb_x + generic, public :: sct => sctb, sctb_x + end type psb_l_multivect_type + + public :: psb_l_multivect, psb_l_multivect_type,& + & psb_set_multivect_default, psb_get_multivect_default, & + & psb_l_base_multivect_type + + private + interface psb_l_multivect + module procedure constructor, size_const + end interface psb_l_multivect + + class(psb_l_base_multivect_type), allocatable, target,& + & save, private :: psb_l_base_multivect_default + + interface psb_set_multivect_default + module procedure psb_l_set_multivect_default + end interface psb_set_multivect_default + + interface psb_get_multivect_default + module procedure psb_l_get_multivect_default + end interface psb_get_multivect_default + + +contains + + + subroutine psb_l_set_multivect_default(v) + implicit none + class(psb_l_base_multivect_type), intent(in) :: v + + if (allocated(psb_l_base_multivect_default)) then + deallocate(psb_l_base_multivect_default) + end if + allocate(psb_l_base_multivect_default, mold=v) + + end subroutine psb_l_set_multivect_default + + function psb_l_get_multivect_default(v) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: v + class(psb_l_base_multivect_type), pointer :: res + + res => psb_l_get_base_multivect_default() + + end function psb_l_get_multivect_default + + + function psb_l_get_base_multivect_default() result(res) + implicit none + class(psb_l_base_multivect_type), pointer :: res + + if (.not.allocated(psb_l_base_multivect_default)) then + allocate(psb_l_base_multivect_type :: psb_l_base_multivect_default) + end if + + res => psb_l_base_multivect_default + + end function psb_l_get_base_multivect_default + + + subroutine l_vect_clone(x,y,info) + implicit none + class(psb_l_multivect_type), intent(inout) :: x + class(psb_l_multivect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + + info = psb_success_ + call y%free(info) + if ((info==0).and.allocated(x%v)) then + call y%bld(x%get_vect(),mold=x%v) + end if + end subroutine l_vect_clone + + subroutine l_vect_bld_x(x,invect,mold) + integer(psb_lpk_), intent(in) :: invect(:,:) + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + class(psb_l_base_multivect_type), pointer :: mld + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) + endif + + if (info == psb_success_) call x%v%bld(invect) + + end subroutine l_vect_bld_x + + + subroutine l_vect_bld_n(x,m,n,mold) + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + + info = psb_success_ + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_l_get_base_multivect_default()) + endif + if (info == psb_success_) call x%v%bld(m,n) + + end subroutine l_vect_bld_n + + function l_vect_get_vect(x) result(res) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), allocatable :: res(:,:) + integer(psb_ipk_) :: info + + if (allocated(x%v)) then + res = x%v%get_vect() + end if + end function l_vect_get_vect + + subroutine l_vect_set_scal(x,val) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine l_vect_set_scal + + subroutine l_vect_set_vect(x,val) + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: val(:,:) + + integer(psb_ipk_) :: info + if (allocated(x%v)) call x%v%set(val) + + end subroutine l_vect_set_vect + + + function constructor(x) result(this) + integer(psb_lpk_) :: x(:,:) + type(psb_l_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%bld(x) + call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info) + + end function constructor + + + function size_const(m,n) result(this) + integer(psb_ipk_), intent(in) :: m,n + type(psb_l_multivect_type) :: this + integer(psb_ipk_) :: info + + call this%bld(m,n) + call this%asb(m,n,info) + + end function size_const + + function l_vect_get_nrows(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_nrows() + end function l_vect_get_nrows + + function l_vect_get_ncols(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + integer(psb_ipk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%get_ncols() + end function l_vect_get_ncols + + function l_vect_sizeof(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + integer(psb_epk_) :: res + res = 0 + if (allocated(x%v)) res = x%v%sizeof() + end function l_vect_sizeof + + function l_vect_get_fmt(x) result(res) + implicit none + class(psb_l_multivect_type), intent(in) :: x + character(len=5) :: res + res = 'NULL' + if (allocated(x%v)) res = x%v%get_fmt() + end function l_vect_get_fmt + + subroutine l_vect_all(m,n, x, info, mold) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(out) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), intent(out) :: info + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(psb_l_base_multivect_type :: x%v,stat=info) + endif + if (info == 0) then + call x%v%all(m,n,info) + else + info = psb_err_alloc_dealloc_ + end if + + end subroutine l_vect_all + + subroutine l_vect_reall(m,n, x, info) + + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (.not.allocated(x%v)) & + & call x%all(m,n,info) + if (info == 0) & + & call x%asb(m,n,info) + + end subroutine l_vect_reall + + subroutine l_vect_zero(x) + use psi_serial_mod + implicit none + class(psb_l_multivect_type), intent(inout) :: x + + if (allocated(x%v)) call x%v%zero() + + end subroutine l_vect_zero + + subroutine l_vect_asb(m,n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_ipk_), intent(in) :: m,n + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + if (allocated(x%v)) & + & call x%v%asb(m,n,info) + + end subroutine l_vect_asb + + subroutine l_vect_sync(x) + implicit none + class(psb_l_multivect_type), intent(inout) :: x + + if (allocated(x%v)) & + & call x%v%sync() + + end subroutine l_vect_sync + + subroutine l_vect_gthab(n,idx,alpha,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: alpha, beta, y(:) + class(psb_l_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,alpha,beta,y) + + end subroutine l_vect_gthab + + subroutine l_vect_gthzv(n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: y(:) + class(psb_l_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(n,idx,y) + + end subroutine l_vect_gthzv + + subroutine l_vect_gthzv_x(i,n,idx,x,y) + use psi_serial_mod + integer(psb_ipk_) :: i,n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: y(:) + class(psb_l_multivect_type) :: x + + if (allocated(x%v)) & + & call x%v%gth(i,n,idx,y) + + end subroutine l_vect_gthzv_x + + subroutine l_vect_sctb(n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: n, idx(:) + integer(psb_lpk_) :: beta, x(:) + class(psb_l_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(n,idx,x,beta) + + end subroutine l_vect_sctb + + subroutine l_vect_sctb_x(i,n,idx,x,beta,y) + use psi_serial_mod + integer(psb_ipk_) :: i, n + class(psb_i_base_vect_type) :: idx + integer(psb_lpk_) :: beta, x(:) + class(psb_l_multivect_type) :: y + + if (allocated(y%v)) & + & call y%v%sct(i,n,idx,x,beta) + + end subroutine l_vect_sctb_x + + subroutine l_vect_free(x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(x%v)) then + call x%v%free(info) + if (info == 0) deallocate(x%v,stat=info) + end if + + end subroutine l_vect_free + + subroutine l_vect_ins(n,irl,val,dupl,x,info) + use psi_serial_mod + implicit none + class(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: n, dupl + integer(psb_ipk_), intent(in) :: irl(:) + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i + + info = 0 + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + return + end if + + call x%v%ins(n,irl,val,dupl,info) + + end subroutine l_vect_ins + + + subroutine l_vect_cnv(x,mold) + class(psb_l_multivect_type), intent(inout) :: x + class(psb_l_base_multivect_type), intent(in), optional :: mold + class(psb_l_base_multivect_type), allocatable :: tmp + integer(psb_ipk_) :: info + + if (present(mold)) then + allocate(tmp,stat=info,mold=mold) + else + allocate(tmp,stat=info, mold=psb_l_get_base_multivect_default()) + endif + if (allocated(x%v)) then + call x%v%sync() + if (info == psb_success_) call tmp%bld(x%v%v) + call x%v%free(info) + end if + call move_alloc(tmp,x%v) + end subroutine l_vect_cnv + + +end module psb_l_multivect_mod diff --git a/base/modules/serial/psb_s_base_mat_mod.f90 b/base/modules/serial/psb_s_base_mat_mod.f90 index 4181dcc8a..52189abc6 100644 --- a/base/modules/serial/psb_s_base_mat_mod.f90 +++ b/base/modules/serial/psb_s_base_mat_mod.f90 @@ -79,6 +79,18 @@ module psb_s_base_mat_mod procedure, pass(a) :: clone => psb_s_base_clone procedure, pass(a) :: make_nonunit => psb_s_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_s_base_clean_zeros + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_lcoo => psb_s_base_cp_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_s_base_cp_from_lcoo + procedure, pass(a) :: cp_to_lfmt => psb_s_base_cp_to_lfmt + procedure, pass(a) :: cp_from_lfmt => psb_s_base_cp_from_lfmt + procedure, pass(a) :: mv_to_lcoo => psb_s_base_mv_to_lcoo + procedure, pass(a) :: mv_from_lcoo => psb_s_base_mv_from_lcoo + procedure, pass(a) :: mv_to_lfmt => psb_s_base_mv_to_lfmt + procedure, pass(a) :: mv_from_lfmt => psb_s_base_mv_from_lfmt + ! ! Transpose methods: defined here but not implemented. @@ -115,7 +127,10 @@ module psb_s_base_mat_mod procedure, pass(a) :: aclsum => psb_s_base_aclsum end type psb_s_base_sparse_mat - + private :: s_base_mat_sync, s_base_mat_is_host, s_base_mat_is_dev, & + & s_base_mat_is_sync, s_base_mat_set_host, s_base_mat_set_dev,& + & s_base_mat_set_sync + !> \namespace psb_base_mod \class psb_s_coo_sparse_mat !! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat !! @@ -155,6 +170,13 @@ module psb_s_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_s_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_s_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_s_mv_coo_from_fmt + + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_lcoo => psb_s_cp_coo_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_s_cp_coo_from_lcoo + procedure, pass(a) :: csput_a => psb_s_coo_csput_a procedure, pass(a) :: get_diag => psb_s_coo_get_diag procedure, pass(a) :: csgetrow => psb_s_coo_csgetrow @@ -212,6 +234,183 @@ module psb_s_base_mat_mod & s_coo_transp_1mat, s_coo_transc_1mat + !> \namespace psb_base_mod \class psb_ls_base_sparse_mat + !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat + !! The psb_ls_base_sparse_mat type, extending psb_base_sparse_mat, + !! defines a middle level real(psb_spk_) sparse matrix object. + !! This class object itself does not have any additional members + !! with respect to those of the base class. Most methods cannot be fully + !! implemented at this level, but we can define the interface for the + !! computational methods requiring the knowledge of the underlying + !! field, such as the matrix-vector product; this interface is defined, + !! but is supposed to be overridden at the leaf level. + !! + !! About the method MOLD: this has been defined for those compilers + !! not yet supporting ALLOCATE( ...,MOLD=...); it's otherwise silly to + !! duplicate "by hand" what is specified in the language (in this case F2008) + !! + type, extends(psb_lbase_sparse_mat) :: psb_ls_base_sparse_mat + contains + ! + ! Data management methods: defined here, but (mostly) not implemented. + ! + procedure, pass(a) :: csput_a => psb_ls_base_csput_a + procedure, pass(a) :: csput_v => psb_ls_base_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetrow => psb_ls_base_csgetrow + procedure, pass(a) :: csgetblk => psb_ls_base_csgetblk + procedure, pass(a) :: get_diag => psb_ls_base_get_diag + generic, public :: csget => csgetrow, csgetblk + procedure, pass(a) :: tril => psb_ls_base_tril + procedure, pass(a) :: triu => psb_ls_base_triu + procedure, pass(a) :: csclip => psb_ls_base_csclip + procedure, pass(a) :: cp_to_coo => psb_ls_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_ls_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ls_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ls_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ls_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_ls_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ls_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ls_base_mv_from_fmt + procedure, pass(a) :: mold => psb_ls_base_mold + procedure, pass(a) :: clone => psb_ls_base_clone + procedure, pass(a) :: make_nonunit => psb_ls_base_make_nonunit + procedure, pass(a) :: clean_zeros => psb_ls_base_clean_zeros + + ! + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_ls_base_scals + procedure, pass(a) :: scalv => psb_ls_base_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: maxval => psb_ls_base_maxval + procedure, pass(a) :: spnmi => psb_ls_base_csnmi + procedure, pass(a) :: spnm1 => psb_ls_base_csnm1 + procedure, pass(a) :: rowsum => psb_ls_base_rowsum + procedure, pass(a) :: arwsum => psb_ls_base_arwsum + procedure, pass(a) :: colsum => psb_ls_base_colsum + procedure, pass(a) :: aclsum => psb_ls_base_aclsum + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_icoo => psb_ls_base_cp_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_ls_base_cp_from_icoo + procedure, pass(a) :: cp_to_ifmt => psb_ls_base_cp_to_ifmt + procedure, pass(a) :: cp_from_ifmt => psb_ls_base_cp_from_ifmt + procedure, pass(a) :: mv_to_icoo => psb_ls_base_mv_to_icoo + procedure, pass(a) :: mv_from_icoo => psb_ls_base_mv_from_icoo + procedure, pass(a) :: mv_to_ifmt => psb_ls_base_mv_to_ifmt + procedure, pass(a) :: mv_from_ifmt => psb_ls_base_mv_from_ifmt + + ! + ! Transpose methods: defined here but not implemented. + ! + procedure, pass(a) :: transp_1mat => psb_ls_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_ls_base_transp_2mat + procedure, pass(a) :: transc_1mat => psb_ls_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_ls_base_transc_2mat + + end type psb_ls_base_sparse_mat + + private :: ls_base_mat_sync, ls_base_mat_is_host, ls_base_mat_is_dev, & + & ls_base_mat_is_sync, ls_base_mat_set_host, ls_base_mat_set_dev,& + & ls_base_mat_set_sync + + !> \namespace psb_base_mod \class psb_ls_coo_sparse_mat + !! \extends psb_ls_base_mat_mod::psb_ls_base_sparse_mat + !! + !! psb_ls_coo_sparse_mat type and the related methods. This is the + !! reference type for all the format transitions, copies and mv unless + !! methods are implemented that allow the direct transition from one + !! format to another. It is defined here since all other classes must + !! refer to it per the MEDIATOR design pattern. + !! + type, extends(psb_ls_base_sparse_mat) :: psb_ls_coo_sparse_mat + !> Number of nonzeros. + integer(psb_lpk_) :: nnz + !> Row indices. + integer(psb_lpk_), allocatable :: ia(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + real(psb_spk_), allocatable :: val(:) + + integer, private :: sort_status=psb_unsorted_ + + contains + ! + ! Data management methods. + ! + procedure, pass(a) :: get_size => ls_coo_get_size + procedure, pass(a) :: get_nzeros => ls_coo_get_nzeros + procedure, nopass :: get_fmt => ls_coo_get_fmt + procedure, pass(a) :: sizeof => ls_coo_sizeof + procedure, pass(a) :: reallocate_nz => psb_ls_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_ls_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_ls_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => psb_ls_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ls_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ls_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ls_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => psb_ls_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ls_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ls_mv_coo_from_fmt + procedure, pass(a) :: cp_to_icoo => psb_ls_cp_coo_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_ls_cp_coo_from_icoo + + procedure, pass(a) :: csput_a => psb_ls_coo_csput_a + procedure, pass(a) :: get_diag => psb_ls_coo_get_diag + procedure, pass(a) :: csgetrow => psb_ls_coo_csgetrow + procedure, pass(a) :: csgetptn => psb_ls_coo_csgetptn + procedure, pass(a) :: reinit => psb_ls_coo_reinit + procedure, pass(a) :: get_nz_row => psb_ls_coo_get_nz_row + procedure, pass(a) :: fix => psb_ls_fix_coo + procedure, pass(a) :: trim => psb_ls_coo_trim + procedure, pass(a) :: clean_zeros => psb_ls_coo_clean_zeros + procedure, pass(a) :: print => psb_ls_coo_print + procedure, pass(a) :: free => ls_coo_free + procedure, pass(a) :: mold => psb_ls_coo_mold + procedure, pass(a) :: is_sorted => ls_coo_is_sorted + procedure, pass(a) :: is_by_rows => ls_coo_is_by_rows + procedure, pass(a) :: is_by_cols => ls_coo_is_by_cols + procedure, pass(a) :: set_by_rows => ls_coo_set_by_rows + procedure, pass(a) :: set_by_cols => ls_coo_set_by_cols + procedure, pass(a) :: set_sort_status => ls_coo_set_sort_status + procedure, pass(a) :: get_sort_status => ls_coo_get_sort_status + + + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_ls_coo_scals + procedure, pass(a) :: scalv => psb_ls_coo_scal + procedure, pass(a) :: maxval => psb_ls_coo_maxval + procedure, pass(a) :: spnmi => psb_ls_coo_csnmi + procedure, pass(a) :: spnm1 => psb_ls_coo_csnm1 + procedure, pass(a) :: rowsum => psb_ls_coo_rowsum + procedure, pass(a) :: arwsum => psb_ls_coo_arwsum + procedure, pass(a) :: colsum => psb_ls_coo_colsum + procedure, pass(a) :: aclsum => psb_ls_coo_aclsum + + ! + ! This is COO specific + ! + procedure, pass(a) :: set_nzeros => ls_coo_set_nzeros + + ! + ! Transpose methods. These are the base of all + ! indirection in transpose, together with conversions + ! they are sufficient for all cases. + ! + procedure, pass(a) :: transp_1mat => ls_coo_transp_1mat + procedure, pass(a) :: transc_1mat => ls_coo_transc_1mat + + + end type psb_ls_coo_sparse_mat + + private :: ls_coo_get_nzeros, ls_coo_set_nzeros, & + & ls_coo_get_fmt, ls_coo_free, ls_coo_sizeof, & + & ls_coo_transp_1mat, ls_coo_transc_1mat + ! == ================= ! @@ -257,7 +456,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -268,8 +467,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_, psb_s_base_vect_type,& - & psb_i_base_vect_type + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -314,7 +512,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -324,7 +522,7 @@ module psb_s_base_mat_mod logical, intent(in), optional :: append integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale, chksz + logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_s_base_csgetrow end interface @@ -353,7 +551,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -391,7 +589,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -432,7 +630,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -476,7 +674,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -499,7 +697,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_get_diag(a,d,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -518,7 +716,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_mold(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_long_int_k_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -540,7 +738,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_clone(a,b, info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_long_int_k_ + import implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), allocatable, intent(inout) :: b @@ -559,7 +757,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_make_nonunit(a) - import :: psb_s_base_sparse_mat + import implicit none class(psb_s_base_sparse_mat), intent(inout) :: a end subroutine psb_s_base_make_nonunit @@ -576,7 +774,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_cp_to_coo(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -593,7 +791,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_cp_from_coo(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -611,7 +809,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_cp_to_fmt(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -629,7 +827,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_cp_from_fmt(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -646,7 +844,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_mv_to_coo(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -663,7 +861,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_mv_from_coo(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -681,7 +879,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_mv_to_fmt(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -699,12 +897,153 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_mv_from_fmt(a,b,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_mv_from_fmt end interface + ! + !> Function cp_to_coo: + !! \memberof psb_s_base_sparse_mat + !! \brief Copy and convert to psb_s_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_s_base_cp_to_lcoo(a,b,info) + import + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_cp_to_lcoo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_s_base_sparse_mat + !! \brief Copy and convert from psb_s_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_s_base_cp_from_lcoo(a,b,info) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_cp_from_lcoo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_s_base_sparse_mat + !! \brief Copy and convert to a class(psb_s_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_s_base_cp_to_lfmt(a,b,info) + import + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_cp_to_lfmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_s_base_sparse_mat + !! \brief Copy and convert from a class(psb_s_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_s_base_cp_from_lfmt(a,b,info) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_cp_from_lfmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_s_base_sparse_mat + !! \brief Convert to psb_s_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_s_base_mv_to_lcoo(a,b,info) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_mv_to_lcoo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_s_base_sparse_mat + !! \brief Convert from psb_s_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_s_base_mv_from_lcoo(a,b,info) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_mv_from_lcoo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_s_base_sparse_mat + !! \brief Convert to a class(psb_s_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_s_base_mv_to_lfmt(a,b,info) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_mv_to_lfmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_s_base_sparse_mat + !! \brief Convert from a class(psb_s_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_s_base_mv_from_lfmt(a,b,info) + import + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_mv_from_lfmt + end interface + + ! !> !! \memberof psb_s_base_sparse_mat @@ -712,7 +1051,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_clean_zeros(a, info) - import :: psb_ipk_, psb_s_base_sparse_mat + import class(psb_s_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_clean_zeros @@ -728,7 +1067,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_transp_2mat(a,b) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_s_base_transp_2mat @@ -744,7 +1083,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_transc_2mat(a,b) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_s_base_transc_2mat @@ -759,7 +1098,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_transp_1mat(a) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a end subroutine psb_s_base_transp_1mat end interface @@ -773,7 +1112,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_transc_1mat(a) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a end subroutine psb_s_base_transc_1mat end interface @@ -798,7 +1137,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -826,7 +1165,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -861,7 +1200,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_vect_mv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_, psb_s_base_vect_type + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x @@ -893,7 +1232,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -928,7 +1267,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -963,7 +1302,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_, psb_s_base_vect_type + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x, y @@ -995,7 +1334,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1028,7 +1367,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1062,7 +1401,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_,psb_s_base_vect_type + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta class(psb_s_base_vect_type), intent(inout) :: x,y @@ -1082,7 +1421,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_scals(d,a,info) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1100,7 +1439,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_scal(d,a,info,side) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1116,7 +1455,7 @@ module psb_s_base_mat_mod ! interface function psb_s_base_maxval(a) result(res) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_base_maxval @@ -1131,7 +1470,7 @@ module psb_s_base_mat_mod ! interface function psb_s_base_csnmi(a) result(res) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_base_csnmi @@ -1146,7 +1485,7 @@ module psb_s_base_mat_mod ! interface function psb_s_base_csnm1(a) result(res) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_base_csnm1 @@ -1162,7 +1501,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_rowsum(d,a) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_base_rowsum @@ -1176,7 +1515,7 @@ module psb_s_base_mat_mod !! interface subroutine psb_s_base_arwsum(d,a) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_base_arwsum @@ -1192,7 +1531,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_base_colsum(d,a) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_base_colsum @@ -1206,7 +1545,7 @@ module psb_s_base_mat_mod !! interface subroutine psb_s_base_aclsum(d,a) - import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_ + import class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_base_aclsum @@ -1226,7 +1565,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_coo_reallocate_nz(nz,a) - import :: psb_ipk_, psb_s_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_s_coo_sparse_mat), intent(inout) :: a end subroutine psb_s_coo_reallocate_nz @@ -1239,7 +1578,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_coo_reinit(a,clear) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_s_coo_reinit @@ -1251,7 +1590,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_coo_trim(a) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a end subroutine psb_s_coo_trim end interface @@ -1262,7 +1601,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_coo_clean_zeros(a,info) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_clean_zeros @@ -1275,7 +1614,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_s_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -1287,7 +1626,7 @@ module psb_s_base_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_s_coo_mold(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ + import class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -1309,7 +1648,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_s_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -1330,7 +1669,7 @@ module psb_s_base_mat_mod ! interface function psb_s_coo_get_nz_row(idx,a) result(res) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res @@ -1354,11 +1693,12 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import :: psb_ipk_, psb_spk_ + import integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) real(psb_spk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout, info + integer(psb_ipk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_s_fix_coo_inner end interface @@ -1373,7 +1713,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_fix_coo(a,info,idir) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir @@ -1385,7 +1725,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_to_coo interface subroutine psb_s_cp_coo_to_coo(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1397,12 +1737,35 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo interface subroutine psb_s_cp_coo_from_coo(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_s_cp_coo_from_coo end interface + !> + !! \memberof psb_s_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_s_base_cp_to_coo + interface + subroutine psb_s_cp_coo_to_lcoo(a,b,info) + import + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_cp_coo_to_lcoo + end interface + + !> + !! \memberof psb_s_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo + interface + subroutine psb_s_cp_coo_from_lcoo(a,b,info) + import + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_cp_coo_from_lcoo + end interface !> !! \memberof psb_s_coo_sparse_mat @@ -1410,7 +1773,7 @@ module psb_s_base_mat_mod !! interface subroutine psb_s_cp_coo_to_fmt(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1423,7 +1786,7 @@ module psb_s_base_mat_mod !! interface subroutine psb_s_cp_coo_from_fmt(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -1435,7 +1798,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_to_coo interface subroutine psb_s_mv_coo_to_coo(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1447,7 +1810,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_from_coo interface subroutine psb_s_mv_coo_from_coo(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1459,7 +1822,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_to_fmt interface subroutine psb_s_mv_coo_to_fmt(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1471,7 +1834,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_from_fmt interface subroutine psb_s_mv_coo_from_fmt(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_coo_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1480,7 +1843,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_coo_cp_from(a,b) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(inout) :: a type(psb_s_coo_sparse_mat), intent(in) :: b end subroutine psb_s_coo_cp_from @@ -1488,7 +1851,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_coo_mv_from(a,b) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(inout) :: a type(psb_s_coo_sparse_mat), intent(inout) :: b end subroutine psb_s_coo_mv_from @@ -1513,7 +1876,7 @@ module psb_s_base_mat_mod ! interface subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -1529,7 +1892,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1548,7 +1911,7 @@ module psb_s_base_mat_mod interface subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1567,7 +1930,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cssv interface subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1580,7 +1943,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cssm interface subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1594,7 +1957,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csmv interface subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -1608,7 +1971,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csmm interface subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -1623,7 +1986,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_maxval interface function psb_s_coo_maxval(a) result(res) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_coo_maxval @@ -1634,7 +1997,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csnmi interface function psb_s_coo_csnmi(a) result(res) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_coo_csnmi @@ -1645,7 +2008,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csnm1 interface function psb_s_coo_csnm1(a) result(res) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_coo_csnm1 @@ -1656,7 +2019,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_rowsum interface subroutine psb_s_coo_rowsum(d,a) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_coo_rowsum @@ -1666,7 +2029,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_arwsum interface subroutine psb_s_coo_arwsum(d,a) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_coo_arwsum @@ -1677,7 +2040,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_colsum interface subroutine psb_s_coo_colsum(d,a) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_coo_colsum @@ -1688,7 +2051,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_aclsum interface subroutine psb_s_coo_aclsum(d,a) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_coo_aclsum @@ -1699,7 +2062,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_get_diag interface subroutine psb_s_coo_get_diag(a,d,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1711,7 +2074,7 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_scal interface subroutine psb_s_coo_scal(d,a,info,side) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1724,13 +2087,1351 @@ module psb_s_base_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_scals interface subroutine psb_s_coo_scals(d,a,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_coo_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_scals end interface + ! == ================= + ! + ! BASE interfaces + ! + ! == ================= + + !> Function csput: + !! \memberof psb_ls_base_sparse_mat + !! \brief Insert coefficients. + !! + !! + !! Given a list of NZ triples + !! (IA(i),JA(i),VAL(i)) + !! record a new coefficient in A such that + !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). + !! + !! The internal components IA,JA,VAL are reallocated as necessary. + !! Constraints: + !! - If the matrix A is in the BUILD state, then the method will + !! only work for COO matrices, all other format will throw an error. + !! In this case coefficients are queued inside A for further processing. + !! - If the matrix A is in the UPDATE state, then it can be in any format; + !! the update operation will perform either + !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ) + !! or + !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) + !! according to the value of DUPLICATE. + !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! + !! \param nz number of triples in input + !! \param ia(:) the input row indices + !! \param ja(:) the input col indices + !! \param val(:) the input coefficients + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index + !! \param info return code + !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) + !! + ! + interface + subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_base_csput_a + end interface + + interface + subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_base_csput_v + end interface + + ! + ! + !> Function csgetrow: + !! \memberof psb_ls_base_sparse_mat + !! \brief Get a (subset of) row(s) + !! + !! getrow is the basic method by which the other (getblk, clip) can + !! be implemented. + !! + !! Returns the set + !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) + !! each identifying the position of a nonzero in A + !! between row indices IMIN:IMAX; + !! IA,JA are reallocated as necessary. + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param nz the number of output coefficients + !! \param ia(:) the output row indices + !! \param ja(:) the output col indices + !! \param val(:) the output coefficients + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_ls_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_base_csgetrow + end interface + + ! + !> Function csgetblk: + !! \memberof psb_ls_base_sparse_mat + !! \brief Get a (subset of) row(s) + !! + !! getblk is very similar to getrow, except that the output + !! is packaged in a psb_ls_coo_sparse_mat object + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param b the output (sub)matrix + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_ls_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_base_csgetblk + end interface + + ! + ! + !> Function csclip: + !! \memberof psb_ls_base_sparse_mat + !! \brief Get a submatrix. + !! + !! csclip is practically identical to getblk. + !! One of them has to go away..... + !! + !! \param b the output submatrix + !! \param info return code + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_ls_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_base_csclip + end interface + ! + !> Function tril: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_ls_base_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_ls_base_tril + end interface + + ! + !> Function triu: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_ls_base_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_ls_base_triu + end interface + + + ! + !> Function get_diag: + !! \memberof psb_ls_base_sparse_mat + !! \brief Extract the diagonal of A. + !! + !! D(i) = A(i:i), i=1:min(nrows,ncols) + !! + !! \param d(:) The output diagonal + !! \param info return code. + ! + interface + subroutine psb_ls_base_get_diag(a,d,info) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_get_diag + end interface + + ! + !> Function mold: + !! \memberof psb_ls_base_sparse_mat + !! \brief Allocate a class(psb_ls_base_sparse_mat) with the + !! same dynamic type as the input. + !! This is equivalent to allocate( mold= ) and is provided + !! for those compilers not yet supporting mold. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mold(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mold + end interface + + ! + ! + !> Function clone: + !! \memberof psb_ls_base_sparse_mat + !! \brief Allocate and clone a class(psb_ls_base_sparse_mat) with the + !! same dynamic type as the input. + !! This is equivalent to allocate( source= ) except that + !! it should guarantee a deep copy wherever needed. + !! Should also be equivalent to calling mold and then copy, + !! but it can also be implemented by default using cp_to_fmt. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_clone(a,b, info) + import + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_clone + end interface + + + ! + ! + !> Function make_nonunit: + !! \memberof psb_ls_base_make_nonunit + !! \brief Given a matrix for which is_unit() is true, explicitly + !! store the unit diagonal and set is_unit() to false. + !! This is needed e.g. when scaling + ! + interface + subroutine psb_ls_base_make_nonunit(a) + import + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + end subroutine psb_ls_base_make_nonunit + end interface + + + ! + !> Function cp_to_coo: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy and convert to psb_ls_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_cp_to_coo(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_cp_to_coo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy and convert from psb_ls_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_ls_base_cp_from_coo(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_cp_from_coo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy and convert to a class(psb_ls_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_cp_to_fmt(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_cp_to_fmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy and convert from a class(psb_ls_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_cp_from_fmt(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_cp_from_fmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_ls_base_sparse_mat + !! \brief Convert to psb_ls_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mv_to_coo(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mv_to_coo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_ls_base_sparse_mat + !! \brief Convert from psb_ls_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mv_from_coo(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mv_from_coo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_ls_base_sparse_mat + !! \brief Convert to a class(psb_ls_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mv_to_fmt(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mv_to_fmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_ls_base_sparse_mat + !! \brief Convert from a class(psb_ls_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mv_from_fmt(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mv_from_fmt + end interface + + + ! + !> Function cp_to_coo: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy and convert to psb_ls_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_cp_to_icoo(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_cp_to_icoo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy and convert from psb_ls_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_ls_base_cp_from_icoo(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_cp_from_icoo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy and convert to a class(psb_ls_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_cp_to_ifmt(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_cp_to_ifmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_ls_base_sparse_mat + !! \brief Copy and convert from a class(psb_ls_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_cp_from_ifmt(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_cp_from_ifmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_ls_base_sparse_mat + !! \brief Convert to psb_ls_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mv_to_icoo(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mv_to_icoo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_ls_base_sparse_mat + !! \brief Convert from psb_ls_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mv_from_icoo(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mv_from_icoo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_ls_base_sparse_mat + !! \brief Convert to a class(psb_ls_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mv_to_ifmt(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mv_to_ifmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_ls_base_sparse_mat + !! \brief Convert from a class(psb_ls_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_ls_base_mv_from_ifmt(a,b,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_mv_from_ifmt + end interface + + + + ! + !> + !! \memberof psb_ls_base_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_clean_zeros + ! + interface + subroutine psb_ls_base_clean_zeros(a, info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_clean_zeros + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_maxval + interface + function psb_ls_coo_maxval(a) result(res) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_coo_maxval + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_csnmi + interface + function psb_ls_coo_csnmi(a) result(res) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_coo_csnmi + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_csnm1 + interface + function psb_ls_coo_csnm1(a) result(res) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_coo_csnm1 + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_rowsum + interface + subroutine psb_ls_coo_rowsum(d,a) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_coo_rowsum + end interface + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_arwsum + interface + subroutine psb_ls_coo_arwsum(d,a) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_coo_arwsum + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_colsum + interface + subroutine psb_ls_coo_colsum(d,a) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_coo_colsum + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_aclsum + interface + subroutine psb_ls_coo_aclsum(d,a) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_coo_aclsum + end interface + + ! + !> Function base_scals: + !! \memberof psb_ls_base_sparse_mat + !! \brief Scale a matrix by a single scalar value + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_ls_base_scals(d,a,info) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_base_scals + end interface + + ! + !> Function base_scal: + !! \memberof psb_ls_base_sparse_mat + !! \brief Scale a matrix by a vector + !! + !! \param d(:) Scaling vector + !! \param info return code + !! \param side [L] Scale on the Left (rows) or on the Right (columns) + ! + interface + subroutine psb_ls_base_scal(d,a,info,side) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ls_base_scal + end interface + + ! + !> Function base_maxval: + !! \memberof psb_ls_base_sparse_mat + !! \brief Maximum absolute value of all coefficients; + !! + ! + interface + function psb_ls_base_maxval(a) result(res) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_base_maxval + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_ls_base_sparse_mat + !! \brief Operator infinity norm + !! + ! + interface + function psb_ls_base_csnmi(a) result(res) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_base_csnmi + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_ls_base_sparse_mat + !! \brief Operator 1-norm + !! + ! + interface + function psb_ls_base_csnm1(a) result(res) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_base_csnm1 + end interface + + ! + ! + !> Function base_rowsum: + !! \memberof psb_ls_base_sparse_mat + !! \brief Sum along the rows + !! \param d(:) The output row sums + !! + ! + interface + subroutine psb_ls_base_rowsum(d,a) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_base_rowsum + end interface + + ! + !> Function base_arwsum: + !! \memberof psb_ls_base_sparse_mat + !! \brief Absolute value sum along the rows + !! \param d(:) The output row sums + !! + interface + subroutine psb_ls_base_arwsum(d,a) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_base_arwsum + end interface + + ! + ! + !> Function base_colsum: + !! \memberof psb_ls_base_sparse_mat + !! \brief Sum along the columns + !! \param d(:) The output col sums + !! + ! + interface + subroutine psb_ls_base_colsum(d,a) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_base_colsum + end interface + + ! + !> Function base_aclsum: + !! \memberof psb_ls_base_sparse_mat + !! \brief Absolute value sum along the columns + !! \param d(:) The output col sums + !! + interface + subroutine psb_ls_base_aclsum(d,a) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_base_aclsum + end interface + + + ! + !> Function transp: + !! \memberof psb_ls_base_sparse_mat + !! \brief Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! Copyout version + !! \param b The output variable + ! + interface + subroutine psb_ls_base_transp_2mat(a,b) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + end subroutine psb_ls_base_transp_2mat + end interface + + ! + !> Function transc: + !! \memberof psb_ls_base_sparse_mat + !! \brief Conjugate Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! Copyout version. + !! \param b The output variable + ! + interface + subroutine psb_ls_base_transc_2mat(a,b) + import + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + end subroutine psb_ls_base_transc_2mat + end interface + + ! + !> Function transp: + !! \memberof psb_ls_base_sparse_mat + !! \brief Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! In-place version. + ! + interface + subroutine psb_ls_base_transp_1mat(a) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + end subroutine psb_ls_base_transp_1mat + end interface + + ! + !> Function transc: + !! \memberof psb_ls_base_sparse_mat + !! \brief Conjugate Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! In-place version. + ! + interface + subroutine psb_ls_base_transc_1mat(a) + import + class(psb_ls_base_sparse_mat), intent(inout) :: a + end subroutine psb_ls_base_transc_1mat + end interface + + ! == =============== + ! + ! COO interfaces + ! + ! == =============== + + ! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reallocate_nz + ! + interface + subroutine psb_ls_coo_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_coo_sparse_mat), intent(inout) :: a + end subroutine psb_ls_coo_reallocate_nz + end interface + + ! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reinit + ! + interface + subroutine psb_ls_coo_reinit(a,clear) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ls_coo_reinit + end interface + ! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_trim + ! + interface + subroutine psb_ls_coo_trim(a) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + end subroutine psb_ls_coo_trim + end interface + ! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_clean_zeros + ! + interface + subroutine psb_ls_coo_clean_zeros(a,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_coo_clean_zeros + end interface + + ! + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_allocate_mnnz + ! + interface + subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ls_coo_allocate_mnnz + end interface + + + !> \memberof psb_ls_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_ls_coo_mold(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_coo_mold + end interface + + + ! + !> Function print. + !! \memberof psb_ls_coo_sparse_mat + !! \brief Print the matrix to file in MatrixMarket format + !! + !! \param iout The unit to write to + !! \param iv [none] Renumbering for both rows and columns + !! \param head [none] Descriptive header for the file + !! \param ivr [none] Row renumbering + !! \param ivc [none] Col renumbering + !! + ! + interface + subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_coo_print + end interface + + + + ! + !> Function get_nz_row. + !! \memberof psb_ls_coo_sparse_mat + !! \brief How many nonzeros in a row? + !! + !! \param idx The row to search. + !! + ! + interface + function psb_ls_coo_get_nz_row(idx,a) result(res) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + end function psb_ls_coo_get_nz_row + end interface + + + ! + !> Funtion: fix_coo_inner + !! \brief Make sure the entries are sorted and duplicates are handled. + !! Used internally by fix_coo + !! \param nzin Number of entries on input to be handled + !! \param dupl What to do with duplicated entries. + !! \param ia(:) Row indices + !! \param ja(:) Col indices + !! \param val(:) Coefficients + !! \param nzout Number of entries after sorting/duplicate handling + !! \param info return code + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! + ! + interface + subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import + integer(psb_lpk_), intent(in) :: nr,nc,nzin + integer(psb_ipk_), intent(in) :: dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + real(psb_spk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + end subroutine psb_ls_fix_coo_inner + end interface + + ! + !> Function fix_coo + !! \memberof psb_ls_coo_sparse_mat + !! \brief Make sure the entries are sorted and duplicates are handled. + !! \param info return code + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! + ! + interface + subroutine psb_ls_fix_coo(a,info,idir) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + end subroutine psb_ls_fix_coo + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo + interface + subroutine psb_ls_cp_coo_to_coo(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_coo_to_coo + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo + interface + subroutine psb_ls_cp_coo_from_coo(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_coo_from_coo + end interface + + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo + interface + subroutine psb_ls_cp_coo_to_icoo(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_coo_to_icoo + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo + interface + subroutine psb_ls_cp_coo_from_icoo(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_coo_from_icoo + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo + !! + interface + subroutine psb_ls_cp_coo_to_fmt(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_coo_to_fmt + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_fmt + !! + interface + subroutine psb_ls_cp_coo_from_fmt(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_coo_from_fmt + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_coo + interface + subroutine psb_ls_mv_coo_to_coo(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_coo_to_coo + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_coo + interface + subroutine psb_ls_mv_coo_from_coo(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_coo_from_coo + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_fmt + interface + subroutine psb_ls_mv_coo_to_fmt(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_coo_to_fmt + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_fmt + interface + subroutine psb_ls_mv_coo_from_fmt(a,b,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_coo_from_fmt + end interface + + interface + subroutine psb_ls_coo_cp_from(a,b) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + type(psb_ls_coo_sparse_mat), intent(in) :: b + end subroutine psb_ls_coo_cp_from + end interface + + interface + subroutine psb_ls_coo_mv_from(a,b) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + type(psb_ls_coo_sparse_mat), intent(inout) :: b + end subroutine psb_ls_coo_mv_from + end interface + + + !> Function csput + !! \memberof psb_ls_coo_sparse_mat + !! \brief Add coefficients into the matrix. + !! + !! \param nz Number of entries to be added + !! \param ia(:) Row indices + !! \param ja(:) Col indices + !! \param val(:) Values + !! \param imin Minimum row index to accept + !! \param imax Maximum row index to accept + !! \param jmin Minimum col index to accept + !! \param jmax Maximum col index to accept + !! \param info return code + !! \param gtl [none] Renumbering for rows/columns + !! + ! + interface + subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_coo_csput_a + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_coo_csgetptn + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csgetrow + interface + subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_coo_csgetrow + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_get_diag + interface + subroutine psb_ls_coo_get_diag(a,d,info) + import + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_coo_get_diag + end interface + + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scal + interface + subroutine psb_ls_coo_scal(d,a,info,side) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ls_coo_scal + end interface + + !> + !! \memberof psb_ls_coo_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scals + interface + subroutine psb_ls_coo_scals(d,a,info) + import + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_coo_scals + end interface contains @@ -1752,11 +3453,11 @@ contains function s_coo_sizeof(a) result(res) implicit none class(psb_s_coo_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + 1 + integer(psb_epk_) :: res + res = 3*psb_sizeof_ip res = res + psb_sizeof_sp * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%ia) - res = res + psb_sizeof_int * psb_size(a%ja) + res = res + psb_sizeof_ip * psb_size(a%ia) + res = res + psb_sizeof_ip * psb_size(a%ja) end function s_coo_sizeof @@ -1902,9 +3603,9 @@ contains if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) - call a%set_nzeros(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) + call a%set_nzeros(0_psb_ipk_) call a%set_sort_status(psb_unsorted_) return @@ -1958,6 +3659,230 @@ contains end subroutine s_coo_transc_1mat + + ! == ================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == ================================== + + + + function ls_coo_sizeof(a) result(res) + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 3*psb_sizeof_lp + res = res + psb_sizeof_sp * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%ia) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function ls_coo_sizeof + + + function ls_coo_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'COO' + end function ls_coo_get_fmt + + + function ls_coo_get_size(a) result(res) + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = -1 + + if (allocated(a%ia)) res = size(a%ia) + if (allocated(a%ja)) then + if (res >= 0) then + res = min(res,size(a%ja)) + else + res = size(a%ja) + end if + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + end function ls_coo_get_size + + + function ls_coo_get_nzeros(a) result(res) + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%nnz + end function ls_coo_get_nzeros + + function ls_coo_is_by_rows(a) result(res) + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_row_major_) + end function ls_coo_is_by_rows + + function ls_coo_is_by_cols(a) result(res) + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_col_major_) + end function ls_coo_is_by_cols + + function ls_coo_is_sorted(a) result(res) + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_row_major_) & + & .or.(a%sort_status == psb_col_major_) + end function ls_coo_is_sorted + + + + ! == ================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == ================================== + + subroutine ls_coo_set_nzeros(nz,a) + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_coo_sparse_mat), intent(inout) :: a + + a%nnz = nz + + end subroutine ls_coo_set_nzeros + + function ls_coo_get_sort_status(a) result(res) + implicit none + integer(psb_ipk_) :: res + class(psb_ls_coo_sparse_mat), intent(in) :: a + + res = a%sort_status + end function ls_coo_get_sort_status + + subroutine ls_coo_set_sort_status(ist,a) + implicit none + integer(psb_ipk_), intent(in) :: ist + class(psb_ls_coo_sparse_mat), intent(inout) :: a + + a%sort_status = ist + call a%set_sorted((a%sort_status == psb_row_major_) & + & .or.(a%sort_status == psb_col_major_)) + end subroutine ls_coo_set_sort_status + + + subroutine ls_coo_set_by_rows(a) + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + + a%sort_status = psb_row_major_ + call a%set_sorted() + end subroutine ls_coo_set_by_rows + + + subroutine ls_coo_set_by_cols(a) + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + + a%sort_status = psb_col_major_ + call a%set_sorted() + end subroutine ls_coo_set_by_cols + + ! == ================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == ================================== + + subroutine ls_coo_free(a) + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + call a%set_nzeros(0_psb_lpk_) + call a%set_sort_status(psb_unsorted_) + + return + + end subroutine ls_coo_free + + + + ! == ================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + ! == ================================== + subroutine ls_coo_transp_1mat(a) + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + + integer(psb_lpk_), allocatable :: itemp(:) + integer(psb_ipk_) :: info + + call a%psb_ls_base_sparse_mat%psb_lbase_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%set_sorted(.false.) + call a%set_sort_status(psb_unsorted_) + + return + + end subroutine ls_coo_transp_1mat + + subroutine ls_coo_transc_1mat(a) + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + + call a%transp() + ! This will morph into conjg() for C and Z + ! and into a no-op for S and D, so a conditional + ! on a constant ought to take it out completely. + if (psb_ls_is_complex_) a%val(:) = (a%val(:)) + + end subroutine ls_coo_transc_1mat + end module psb_s_base_mat_mod diff --git a/base/modules/serial/psb_s_base_vect_mod.f90 b/base/modules/serial/psb_s_base_vect_mod.f90 index 1bbc17500..2d716290b 100644 --- a/base/modules/serial/psb_s_base_vect_mod.f90 +++ b/base/modules/serial/psb_s_base_vect_mod.f90 @@ -48,6 +48,7 @@ module psb_s_base_vect_mod use psb_error_mod use psb_realloc_mod use psb_i_base_vect_mod + use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_s_base_vect_type !! The psb_s_base_vect_type @@ -63,14 +64,15 @@ module psb_s_base_vect_mod !> Values. real(psb_spk_), allocatable :: v(:) real(psb_spk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators ! procedure, pass(x) :: bld_x => s_base_bld_x - procedure, pass(x) :: bld_n => s_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => s_base_bld_mn + procedure, pass(x) :: bld_en => s_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => s_base_all procedure, pass(x) :: mold => s_base_mold ! @@ -82,7 +84,9 @@ module psb_s_base_vect_mod procedure, pass(x) :: ins_v => s_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => s_base_zero - procedure, pass(x) :: asb => s_base_asb + procedure, pass(x) :: asb_m => s_base_asb_m + procedure, pass(x) :: asb_e => s_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => s_base_free ! ! Sync: centerpiece of handling of external storage. @@ -240,22 +244,39 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_s_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine s_base_bld_n(x,n) + subroutine s_base_bld_mn(x,n) use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine s_base_bld_n + end subroutine s_base_bld_mn + + !> Function bld_en: + !! \memberof psb_s_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine s_base_bld_en(x,n) + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine s_base_bld_en !> Function base_all: !! \memberof psb_s_base_vect_type @@ -437,11 +458,11 @@ contains !! ! - subroutine s_base_asb(n, x, info) + subroutine s_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -451,7 +472,37 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine s_base_asb + end subroutine s_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_s_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine s_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine s_base_asb_e ! !> Function base_free: @@ -662,10 +713,10 @@ contains function s_base_sizeof(x) result(res) implicit none class(psb_s_base_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * psb_sizeof_sp) * x%get_nrows() + res = (1_psb_epk_ * psb_sizeof_sp) * x%get_nrows() end function s_base_sizeof @@ -753,7 +804,6 @@ contains integer(psb_ipk_) :: info, first_, last_, nr - first_ = 1 if (present(first)) first_ = max(1,first) last_ = min(psb_size(x%v),first_+size(val)-1) @@ -1415,7 +1465,7 @@ module psb_s_base_multivect_mod !> Values. real(psb_spk_), allocatable :: v(:,:) real(psb_spk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1933,10 +1983,10 @@ contains function s_base_mlv_sizeof(x) result(res) implicit none class(psb_s_base_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() end function s_base_mlv_sizeof diff --git a/base/modules/serial/psb_s_csc_mat_mod.f90 b/base/modules/serial/psb_s_csc_mat_mod.f90 index 9e9361530..1d248c1d1 100644 --- a/base/modules/serial/psb_s_csc_mat_mod.f90 +++ b/base/modules/serial/psb_s_csc_mat_mod.f90 @@ -100,14 +100,69 @@ module psb_s_csc_mat_mod end type psb_s_csc_sparse_mat - private :: s_csc_get_nzeros, s_csc_free, s_csc_get_fmt, & + private :: s_csc_get_nzeros, s_csc_free, s_csc_get_fmt, & & s_csc_get_size, s_csc_sizeof, s_csc_get_nz_col + + !> \namespace psb_base_mod \class psb_s_csc_sparse_mat + !! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat + !! + !! psb_s_csc_sparse_mat type and the related methods. + !! + type, extends(psb_ls_base_sparse_mat) :: psb_ls_csc_sparse_mat + + !> Pointers to beginning of cols in IA and VAL. + integer(psb_lpk_), allocatable :: icp(:) + !> Row indices. + integer(psb_lpk_), allocatable :: ia(:) + !> Coefficient values. + real(psb_spk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_cols => ls_csc_is_by_cols + procedure, pass(a) :: get_size => ls_csc_get_size + procedure, pass(a) :: get_nzeros => ls_csc_get_nzeros + procedure, nopass :: get_fmt => ls_csc_get_fmt + procedure, pass(a) :: sizeof => ls_csc_sizeof + procedure, pass(a) :: scals => psb_ls_csc_scals + procedure, pass(a) :: scalv => psb_ls_csc_scal + procedure, pass(a) :: maxval => psb_ls_csc_maxval + procedure, pass(a) :: spnm1 => psb_ls_csc_csnm1 + procedure, pass(a) :: rowsum => psb_ls_csc_rowsum + procedure, pass(a) :: arwsum => psb_ls_csc_arwsum + procedure, pass(a) :: colsum => psb_ls_csc_colsum + procedure, pass(a) :: aclsum => psb_ls_csc_aclsum + procedure, pass(a) :: reallocate_nz => psb_ls_csc_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_ls_csc_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_ls_cp_csc_to_coo + procedure, pass(a) :: cp_from_coo => psb_ls_cp_csc_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ls_cp_csc_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ls_cp_csc_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ls_mv_csc_to_coo + procedure, pass(a) :: mv_from_coo => psb_ls_mv_csc_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ls_mv_csc_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ls_mv_csc_from_fmt + procedure, pass(a) :: csput_a => psb_ls_csc_csput_a + procedure, pass(a) :: get_diag => psb_ls_csc_get_diag + procedure, pass(a) :: csgetptn => psb_ls_csc_csgetptn + procedure, pass(a) :: csgetrow => psb_ls_csc_csgetrow + procedure, pass(a) :: get_nz_col => ls_csc_get_nz_col + procedure, pass(a) :: reinit => psb_ls_csc_reinit + procedure, pass(a) :: trim => psb_ls_csc_trim + procedure, pass(a) :: print => psb_ls_csc_print + procedure, pass(a) :: free => ls_csc_free + procedure, pass(a) :: mold => psb_ls_csc_mold + + end type psb_ls_csc_sparse_mat + + private :: ls_csc_get_nzeros, ls_csc_free, ls_csc_get_fmt, & + & ls_csc_get_size, ls_csc_sizeof, ls_csc_get_nz_col + !> \memberof psb_s_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface subroutine psb_s_csc_reallocate_nz(nz,a) - import :: psb_ipk_, psb_s_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_s_csc_sparse_mat), intent(inout) :: a end subroutine psb_s_csc_reallocate_nz @@ -117,7 +172,7 @@ module psb_s_csc_mat_mod !| \see psb_base_mat_mod::psb_base_reinit interface subroutine psb_s_csc_reinit(a,clear) - import :: psb_ipk_, psb_s_csc_sparse_mat + import class(psb_s_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_s_csc_reinit @@ -127,7 +182,7 @@ module psb_s_csc_mat_mod !| \see psb_base_mat_mod::psb_base_trim interface subroutine psb_s_csc_trim(a) - import :: psb_ipk_, psb_s_csc_sparse_mat + import class(psb_s_csc_sparse_mat), intent(inout) :: a end subroutine psb_s_csc_trim end interface @@ -136,7 +191,7 @@ module psb_s_csc_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_s_csc_mold(a,b,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ + import class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -147,7 +202,7 @@ module psb_s_csc_mat_mod !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface subroutine psb_s_csc_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_s_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_s_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -159,7 +214,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_print interface subroutine psb_s_csc_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_s_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_s_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -172,7 +227,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_to_coo interface subroutine psb_s_cp_csc_to_coo(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_csc_sparse_mat + import class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -183,7 +238,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo interface subroutine psb_s_cp_csc_from_coo(a,b,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_coo_sparse_mat + import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -194,7 +249,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_to_fmt interface subroutine psb_s_cp_csc_to_fmt(a,b,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -205,7 +260,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_from_fmt interface subroutine psb_s_cp_csc_from_fmt(a,b,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -216,7 +271,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_to_coo interface subroutine psb_s_mv_csc_to_coo(a,b,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_coo_sparse_mat + import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -227,7 +282,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_from_coo interface subroutine psb_s_mv_csc_from_coo(a,b,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_coo_sparse_mat + import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -238,7 +293,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_to_fmt interface subroutine psb_s_mv_csc_to_fmt(a,b,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -249,7 +304,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_from_fmt interface subroutine psb_s_mv_csc_from_fmt(a,b,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_csc_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -260,7 +315,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_from interface subroutine psb_s_csc_cp_from(a,b) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(inout) :: a type(psb_s_csc_sparse_mat), intent(in) :: b end subroutine psb_s_csc_cp_from @@ -270,7 +325,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_from interface subroutine psb_s_csc_mv_from(a,b) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(inout) :: a type(psb_s_csc_sparse_mat), intent(inout) :: b end subroutine psb_s_csc_mv_from @@ -281,7 +336,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csput_a interface subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -296,7 +351,7 @@ module psb_s_csc_mat_mod interface subroutine psb_s_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -328,28 +383,28 @@ module psb_s_csc_mat_mod end subroutine psb_s_csc_csgetrow end interface -!!$ !> \memberof psb_s_csc_sparse_mat -!!$ !! \see psb_s_base_mat_mod::psb_s_base_csgetblk -!!$ interface -!!$ subroutine psb_s_csc_csgetblk(imin,imax,a,b,info,& -!!$ & jmin,jmax,iren,append,rscale,cscale,chksz) -!!$ import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_, psb_s_coo_sparse_mat -!!$ class(psb_s_csc_sparse_mat), intent(in) :: a -!!$ class(psb_s_coo_sparse_mat), intent(inout) :: b -!!$ integer(psb_ipk_), intent(in) :: imin,imax -!!$ integer(psb_ipk_),intent(out) :: info -!!$ logical, intent(in), optional :: append -!!$ integer(psb_ipk_), intent(in), optional :: iren(:) -!!$ integer(psb_ipk_), intent(in), optional :: jmin,jmax -!!$ logical, intent(in), optional :: rscale,cscale,chksz -!!$ end subroutine psb_s_csc_csgetblk -!!$ end interface -!!$ + !> \memberof psb_s_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_s_base_csgetblk + interface + subroutine psb_s_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale,chksz) + import + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale,chksz + end subroutine psb_s_csc_csgetblk + end interface + !> \memberof psb_s_csc_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cssv interface subroutine psb_s_csc_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -361,7 +416,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cssm interface subroutine psb_s_csc_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -374,7 +429,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csmv interface subroutine psb_s_csc_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -387,7 +442,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csmm interface subroutine psb_s_csc_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -401,7 +456,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_maxval interface function psb_s_csc_maxval(a) result(res) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_csc_maxval @@ -411,7 +466,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csnm1 interface function psb_s_csc_csnm1(a) result(res) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_csc_csnm1 @@ -421,7 +476,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_rowsum interface subroutine psb_s_csc_rowsum(d,a) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csc_rowsum @@ -431,7 +486,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_arwsum interface subroutine psb_s_csc_arwsum(d,a) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csc_arwsum @@ -441,7 +496,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_colsum interface subroutine psb_s_csc_colsum(d,a) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csc_colsum @@ -451,7 +506,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_aclsum interface subroutine psb_s_csc_aclsum(d,a) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csc_aclsum @@ -461,7 +516,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_get_diag interface subroutine psb_s_csc_get_diag(a,d,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -472,7 +527,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_scal interface subroutine psb_s_csc_scal(d,a,info,side) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -484,7 +539,7 @@ module psb_s_csc_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_scals interface subroutine psb_s_csc_scals(d,a,info) - import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_ + import class(psb_s_csc_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -492,6 +547,347 @@ module psb_s_csc_mat_mod end interface + ! + ! ls + ! + !> \memberof psb_ls_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_ls_csc_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_csc_sparse_mat), intent(inout) :: a + end subroutine psb_ls_csc_reallocate_nz + end interface + + !> \memberof psb_ls_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_ls_csc_reinit(a,clear) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ls_csc_reinit + end interface + + !> \memberof psb_ls_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_ls_csc_trim(a) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + end subroutine psb_ls_csc_trim + end interface + + !> \memberof psb_ls_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_ls_csc_mold(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csc_mold + end interface + + !> \memberof psb_ls_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_ls_csc_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ls_csc_allocate_mnnz + end interface + + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_print + interface + subroutine psb_ls_csc_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_csc_print + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo + interface + subroutine psb_ls_cp_csc_to_coo(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csc_to_coo + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo + interface + subroutine psb_ls_cp_csc_from_coo(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csc_from_coo + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_fmt + interface + subroutine psb_ls_cp_csc_to_fmt(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csc_to_fmt + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_fmt + interface + subroutine psb_ls_cp_csc_from_fmt(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csc_from_fmt + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_coo + interface + subroutine psb_ls_mv_csc_to_coo(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csc_to_coo + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_coo + interface + subroutine psb_ls_mv_csc_from_coo(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csc_from_coo + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_fmt + interface + subroutine psb_ls_mv_csc_to_fmt(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csc_to_fmt + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_fmt + interface + subroutine psb_ls_mv_csc_from_fmt(a,b,info) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csc_from_fmt + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from + interface + subroutine psb_ls_csc_cp_from(a,b) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + type(psb_ls_csc_sparse_mat), intent(in) :: b + end subroutine psb_ls_csc_cp_from + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from + interface + subroutine psb_ls_csc_mv_from(a,b) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + type(psb_ls_csc_sparse_mat), intent(inout) :: b + end subroutine psb_ls_csc_mv_from + end interface + + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csput_a + interface + subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_csc_csput_a + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_ls_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csc_csgetptn + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csgetrow + interface + subroutine psb_ls_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csc_csgetrow + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csgetblk + interface + subroutine psb_ls_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csc_csgetblk + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_get_diag + interface + subroutine psb_ls_csc_get_diag(a,d,info) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csc_get_diag + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_maxval + interface + function psb_ls_csc_maxval(a) result(res) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csc_maxval + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_csnm1 + interface + function psb_ls_csc_csnm1(a) result(res) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csc_csnm1 + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_rowsum + interface + subroutine psb_ls_csc_rowsum(d,a) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csc_rowsum + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_arwsum + interface + subroutine psb_ls_csc_arwsum(d,a) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csc_arwsum + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_colsum + interface + subroutine psb_ls_csc_colsum(d,a) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csc_colsum + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_aclsum + interface + subroutine psb_ls_csc_aclsum(d,a) + import + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csc_aclsum + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scal + interface + subroutine psb_ls_csc_scal(d,a,info,side) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ls_csc_scal + end interface + + !> \memberof psb_ls_csc_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scals + interface + subroutine psb_ls_csc_scals(d,a,info) + import + class(psb_ls_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csc_scals + end interface + + + contains ! == =================================== @@ -519,11 +915,11 @@ contains function s_csc_sizeof(a) result(res) implicit none class(psb_s_csc_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + integer(psb_epk_) :: res + res = 2 * psb_sizeof_ip res = res + psb_sizeof_sp * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%icp) - res = res + psb_sizeof_int * psb_size(a%ia) + res = res + psb_sizeof_ip * psb_size(a%icp) + res = res + psb_sizeof_ip * psb_size(a%ia) end function s_csc_sizeof @@ -602,11 +998,133 @@ contains if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) return end subroutine s_csc_free + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function ls_csc_is_by_cols(a) result(res) + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function ls_csc_is_by_cols + + ! + ! ls + ! + + function ls_csc_sizeof(a) result(res) + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2*psb_sizeof_lp + res = res + psb_sizeof_sp * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%icp) + res = res + psb_sizeof_lp * psb_size(a%ia) + + end function ls_csc_sizeof + + function ls_csc_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSC' + end function ls_csc_get_fmt + + function ls_csc_get_nzeros(a) result(res) + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%icp(a%get_ncols()+1)-1 + end function ls_csc_get_nzeros + + function ls_csc_get_size(a) result(res) + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ia)) then + res = size(a%ia) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function ls_csc_get_size + + + + function ls_csc_get_nz_col(idx,a) result(res) + use psb_const_mod + implicit none + + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then + res = a%icp(idx+1)-a%icp(idx) + end if + + end function ls_csc_get_nz_col + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + + subroutine ls_csc_free(a) + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + + if (allocated(a%icp)) deallocate(a%icp) + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine ls_csc_free + + + end module psb_s_csc_mat_mod diff --git a/base/modules/serial/psb_s_csr_mat_mod.f90 b/base/modules/serial/psb_s_csr_mat_mod.f90 index 2266ff505..fb9e41396 100644 --- a/base/modules/serial/psb_s_csr_mat_mod.f90 +++ b/base/modules/serial/psb_s_csr_mat_mod.f90 @@ -111,7 +111,7 @@ module psb_s_csr_mat_mod !| \see psb_base_mat_mod::psb_base_reallocate_nz interface subroutine psb_s_csr_reallocate_nz(nz,a) - import :: psb_ipk_, psb_s_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_s_csr_sparse_mat), intent(inout) :: a end subroutine psb_s_csr_reallocate_nz @@ -121,7 +121,7 @@ module psb_s_csr_mat_mod !| \see psb_base_mat_mod::psb_base_reinit interface subroutine psb_s_csr_reinit(a,clear) - import :: psb_ipk_, psb_s_csr_sparse_mat + import class(psb_s_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_s_csr_reinit @@ -131,7 +131,7 @@ module psb_s_csr_mat_mod !| \see psb_base_mat_mod::psb_base_trim interface subroutine psb_s_csr_trim(a) - import :: psb_ipk_, psb_s_csr_sparse_mat + import class(psb_s_csr_sparse_mat), intent(inout) :: a end subroutine psb_s_csr_trim end interface @@ -141,7 +141,7 @@ module psb_s_csr_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_s_csr_mold(a,b,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ + import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -152,7 +152,7 @@ module psb_s_csr_mat_mod !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_s_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_s_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -164,7 +164,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_print interface subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_s_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -205,7 +205,7 @@ module psb_s_csr_mat_mod interface subroutine psb_s_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -249,7 +249,7 @@ module psb_s_csr_mat_mod interface subroutine psb_s_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_coo_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -264,7 +264,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_to_coo interface subroutine psb_s_cp_csr_to_coo(a,b,info) - import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_csr_sparse_mat + import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -275,7 +275,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_from_coo interface subroutine psb_s_cp_csr_from_coo(a,b,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_coo_sparse_mat + import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -286,7 +286,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_to_fmt interface subroutine psb_s_cp_csr_to_fmt(a,b,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -297,7 +297,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_from_fmt interface subroutine psb_s_cp_csr_from_fmt(a,b,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -308,7 +308,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_to_coo interface subroutine psb_s_mv_csr_to_coo(a,b,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_coo_sparse_mat + import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -319,7 +319,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_from_coo interface subroutine psb_s_mv_csr_from_coo(a,b,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_coo_sparse_mat + import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -330,7 +330,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_to_fmt interface subroutine psb_s_mv_csr_to_fmt(a,b,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -341,7 +341,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_from_fmt interface subroutine psb_s_mv_csr_from_fmt(a,b,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_base_sparse_mat + import class(psb_s_csr_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -352,7 +352,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cp_from interface subroutine psb_s_csr_cp_from(a,b) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(inout) :: a type(psb_s_csr_sparse_mat), intent(in) :: b end subroutine psb_s_csr_cp_from @@ -362,7 +362,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_mv_from interface subroutine psb_s_csr_mv_from(a,b) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(inout) :: a type(psb_s_csr_sparse_mat), intent(inout) :: b end subroutine psb_s_csr_mv_from @@ -373,7 +373,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csput_a interface subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -388,7 +388,7 @@ module psb_s_csr_mat_mod interface subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -406,7 +406,7 @@ module psb_s_csr_mat_mod interface subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -419,29 +419,12 @@ module psb_s_csr_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_s_csr_csgetrow end interface -!!$ -!!$ !> \memberof psb_s_csr_sparse_mat -!!$ !! \see psb_s_base_mat_mod::psb_s_base_csgetblk -!!$ interface -!!$ subroutine psb_s_csr_csgetblk(imin,imax,a,b,info,& -!!$ & jmin,jmax,iren,append,rscale,cscale) -!!$ import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_, psb_s_coo_sparse_mat -!!$ class(psb_s_csr_sparse_mat), intent(in) :: a -!!$ class(psb_s_coo_sparse_mat), intent(inout) :: b -!!$ integer(psb_ipk_), intent(in) :: imin,imax -!!$ integer(psb_ipk_),intent(out) :: info -!!$ logical, intent(in), optional :: append -!!$ integer(psb_ipk_), intent(in), optional :: iren(:) -!!$ integer(psb_ipk_), intent(in), optional :: jmin,jmax -!!$ logical, intent(in), optional :: rscale,cscale -!!$ end subroutine psb_s_csr_csgetblk -!!$ end interface - + !> \memberof psb_s_csr_sparse_mat !! \see psb_s_base_mat_mod::psb_s_base_cssv interface subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -453,7 +436,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_cssm interface subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -466,7 +449,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csmv interface subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:) real(psb_spk_), intent(inout) :: y(:) @@ -479,7 +462,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csmm interface subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) @@ -493,7 +476,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_maxval interface function psb_s_csr_maxval(a) result(res) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_csr_maxval @@ -503,7 +486,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_csnmi interface function psb_s_csr_csnmi(a) result(res) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res end function psb_s_csr_csnmi @@ -513,7 +496,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_rowsum interface subroutine psb_s_csr_rowsum(d,a) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csr_rowsum @@ -523,7 +506,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_arwsum interface subroutine psb_s_csr_arwsum(d,a) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csr_arwsum @@ -533,7 +516,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_colsum interface subroutine psb_s_csr_colsum(d,a) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csr_colsum @@ -543,7 +526,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_aclsum interface subroutine psb_s_csr_aclsum(d,a) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) end subroutine psb_s_csr_aclsum @@ -553,7 +536,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_get_diag interface subroutine psb_s_csr_get_diag(a,d,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -564,7 +547,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_scal interface subroutine psb_s_csr_scal(d,a,info,side) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -576,7 +559,7 @@ module psb_s_csr_mat_mod !! \see psb_s_base_mat_mod::psb_s_base_scals interface subroutine psb_s_csr_scals(d,a,info) - import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_ + import class(psb_s_csr_sparse_mat), intent(inout) :: a real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -584,6 +567,471 @@ module psb_s_csr_mat_mod end interface + !> \namespace psb_base_mod \class psb_ls_csr_sparse_mat + !! \extends psb_ls_base_mat_mod::psb_ls_base_sparse_mat + !! + !! psb_ls_csr_sparse_mat type and the related methods. + !! This is a very common storage type, and is the default for assembled + !! matrices in our library + type, extends(psb_ls_base_sparse_mat) :: psb_ls_csr_sparse_mat + + !> Pointers to beginning of rows in JA and VAL. + integer(psb_lpk_), allocatable :: irp(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + real(psb_spk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_rows => ls_csr_is_by_rows + procedure, pass(a) :: get_size => ls_csr_get_size + procedure, pass(a) :: get_nzeros => ls_csr_get_nzeros + procedure, nopass :: get_fmt => ls_csr_get_fmt + procedure, pass(a) :: sizeof => ls_csr_sizeof + procedure, pass(a) :: reallocate_nz => psb_ls_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_ls_csr_allocate_mnnz + procedure, pass(a) :: tril => psb_ls_csr_tril + procedure, pass(a) :: triu => psb_ls_csr_triu + procedure, pass(a) :: cp_to_coo => psb_ls_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_ls_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_ls_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_ls_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_ls_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_ls_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_ls_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_ls_mv_csr_from_fmt + procedure, pass(a) :: csput_a => psb_ls_csr_csput_a + procedure, pass(a) :: get_diag => psb_ls_csr_get_diag + procedure, pass(a) :: csgetptn => psb_ls_csr_csgetptn + procedure, pass(a) :: csgetrow => psb_ls_csr_csgetrow + procedure, pass(a) :: get_nz_row => ls_csr_get_nz_row + procedure, pass(a) :: reinit => psb_ls_csr_reinit + procedure, pass(a) :: trim => psb_ls_csr_trim + procedure, pass(a) :: print => psb_ls_csr_print + procedure, pass(a) :: free => ls_csr_free + procedure, pass(a) :: mold => psb_ls_csr_mold + procedure, pass(a) :: scals => psb_ls_csr_scals + procedure, pass(a) :: scalv => psb_ls_csr_scal + procedure, pass(a) :: maxval => psb_ls_csr_maxval + procedure, pass(a) :: spnmi => psb_ls_csr_csnmi + procedure, pass(a) :: rowsum => psb_ls_csr_rowsum + procedure, pass(a) :: arwsum => psb_ls_csr_arwsum + procedure, pass(a) :: colsum => psb_ls_csr_colsum + procedure, pass(a) :: aclsum => psb_ls_csr_aclsum + + end type psb_ls_csr_sparse_mat + + private :: ls_csr_get_nzeros, ls_csr_free, ls_csr_get_fmt, & + & ls_csr_get_size, ls_csr_sizeof, ls_csr_get_nz_row, & + & ls_csr_is_by_rows + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_ls_csr_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_csr_sparse_mat), intent(inout) :: a + end subroutine psb_ls_csr_reallocate_nz + end interface + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_ls_csr_reinit(a,clear) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ls_csr_reinit + end interface + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_ls_csr_trim(a) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + end subroutine psb_ls_csr_trim + end interface + + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_ls_csr_mold(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csr_mold + end interface + + !> \memberof psb_ls_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ls_csr_allocate_mnnz + end interface + + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_print + interface + subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_csr_print + end interface + ! + !> Function tril: + !! \memberof psb_s_base_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_ls_csr_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_ls_csr_tril + end interface + + ! + !> Function triu: + !! \memberof psb_s_csr_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_ls_csr_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_ls_csr_triu + end interface + + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_coo + interface + subroutine psb_ls_cp_csr_to_coo(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csr_to_coo + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_coo + interface + subroutine psb_ls_cp_csr_from_coo(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csr_from_coo + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_to_fmt + interface + subroutine psb_ls_cp_csr_to_fmt(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csr_to_fmt + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from_fmt + interface + subroutine psb_ls_cp_csr_from_fmt(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_cp_csr_from_fmt + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_coo + interface + subroutine psb_ls_mv_csr_to_coo(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csr_to_coo + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_coo + interface + subroutine psb_ls_mv_csr_from_coo(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csr_from_coo + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_to_fmt + interface + subroutine psb_ls_mv_csr_to_fmt(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csr_to_fmt + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from_fmt + interface + subroutine psb_ls_mv_csr_from_fmt(a,b,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_mv_csr_from_fmt + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_cp_from + interface + subroutine psb_ls_csr_cp_from(a,b) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + type(psb_ls_csr_sparse_mat), intent(in) :: b + end subroutine psb_ls_csr_cp_from + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_mv_from + interface + subroutine psb_ls_csr_mv_from(a,b) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + type(psb_ls_csr_sparse_mat), intent(inout) :: b + end subroutine psb_ls_csr_mv_from + end interface + + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csput_a + interface + subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_csr_csput_a + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_ls_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csr_csgetptn + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_csgetrow + interface + subroutine psb_ls_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csr_csgetrow + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_get_diag + interface + subroutine psb_ls_csr_get_diag(a,d,info) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csr_get_diag + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scal + interface + subroutine psb_ls_csr_scal(d,a,info,side) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ls_csr_scal + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_ls_base_mat_mod::psb_ls_base_scals + interface + subroutine psb_ls_csr_scals(d,a,info) + import + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_csr_scals + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_maxval + interface + function psb_ls_csr_maxval(a) result(res) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csr_maxval + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_csnmi + interface + function psb_ls_csr_csnmi(a) result(res) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csr_csnmi + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_rowsum + interface + subroutine psb_ls_csr_rowsum(d,a) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csr_rowsum + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_arwsum + interface + subroutine psb_ls_csr_arwsum(d,a) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csr_arwsum + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_colsum + interface + subroutine psb_ls_csr_colsum(d,a) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csr_colsum + end interface + + !> \memberof psb_ls_csr_sparse_mat + !! \see psb_s_base_mat_mod::psb_ls_base_aclsum + interface + subroutine psb_ls_csr_aclsum(d,a) + import + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + end subroutine psb_ls_csr_aclsum + end interface + contains @@ -613,11 +1061,11 @@ contains function s_csr_sizeof(a) result(res) implicit none class(psb_s_csr_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + integer(psb_epk_) :: res + res = 2 * psb_sizeof_ip res = res + psb_sizeof_sp * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%irp) - res = res + psb_sizeof_int * psb_size(a%ja) + res = res + psb_sizeof_ip * psb_size(a%irp) + res = res + psb_sizeof_ip * psb_size(a%ja) end function s_csr_sizeof @@ -695,12 +1143,128 @@ contains if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) return end subroutine s_csr_free + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + + function ls_csr_is_by_rows(a) result(res) + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function ls_csr_is_by_rows + + + function ls_csr_sizeof(a) result(res) + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2 * psb_sizeof_lp + res = res + psb_sizeof_sp * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function ls_csr_sizeof + + function ls_csr_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSR' + end function ls_csr_get_fmt + + function ls_csr_get_nzeros(a) result(res) + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%irp(a%get_nrows()+1)-1 + end function ls_csr_get_nzeros + + function ls_csr_get_size(a) result(res) + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ja)) then + res = size(a%ja) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function ls_csr_get_size + + + + function ls_csr_get_nz_row(idx,a) result(res) + + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function ls_csr_get_nz_row + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + subroutine ls_csr_free(a) + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine ls_csr_free + end module psb_s_csr_mat_mod diff --git a/base/modules/serial/psb_s_mat_mod.F90 b/base/modules/serial/psb_s_mat_mod.F90 new file mode 100644 index 000000000..7e68e8a61 --- /dev/null +++ b/base/modules/serial/psb_s_mat_mod.F90 @@ -0,0 +1,2740 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_s_mat_mod +! +! This module contains the definition of the psb_s_sparse type which +! is a generic container for a sparse matrix and it is mostly meant to +! provide a mean of switching, at run-time, among different formats, +! potentially unknown at the library compile-time by adding a layer of +! indirection. This type encapsulates the psb_s_base_sparse_mat class +! inside another class which is the one visible to the user. +! Most methods of the psb_s_mat_mod simply call the methods of the +! encapsulated class. +! The exceptions are mainly cscnv and cp_from/cp_to; these provide +! the functionalities to have the encapsulated class change its +! type dynamically, and to extract/input an inner object. +! +! A sparse matrix has a state corresponding to its progression +! through the application life. +! In particular, computational methods can only be invoked when +! the matrix is in the ASSEMBLED state, whereas the other states are +! dedicated to operations on the internal matrix data. +! A sparse matrix can move between states according to the +! following state transition table. Associated with these states are +! the possible dynamic types of the inner matrix object. +! Only COO matrices can ever be in the BUILD state, whereas +! the ASSEMBLED and UPDATE state can be entered by any class. +! +! In Out Method +!| ---------------------------------- +!| Null Build csall +!| Build Build csput +!| Build Assembled cscnv +!| Assembled Assembled cscnv +!| Assembled Update reinit +!| Update Update csput +!| Update Assembled cscnv +!| * unchanged reall +!| Assembled Null free +! +! +! +! We are also introducing the type psb_lsspmat_type. +! The basic difference with psb_sspmat_type is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! +module psb_s_mat_mod + + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat, psb_ls_csr_sparse_mat + use psb_s_csc_mat_mod, only : psb_s_csc_sparse_mat, psb_ls_csc_sparse_mat + + type :: psb_sspmat_type + + class(psb_s_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_s_get_nrows + procedure, pass(a) :: get_ncols => psb_s_get_ncols + procedure, pass(a) :: get_nzeros => psb_s_get_nzeros + procedure, pass(a) :: get_nz_row => psb_s_get_nz_row + procedure, pass(a) :: get_size => psb_s_get_size + procedure, pass(a) :: get_dupl => psb_s_get_dupl + procedure, pass(a) :: is_null => psb_s_is_null + procedure, pass(a) :: is_bld => psb_s_is_bld + procedure, pass(a) :: is_upd => psb_s_is_upd + procedure, pass(a) :: is_asb => psb_s_is_asb + procedure, pass(a) :: is_sorted => psb_s_is_sorted + procedure, pass(a) :: is_by_rows => psb_s_is_by_rows + procedure, pass(a) :: is_by_cols => psb_s_is_by_cols + procedure, pass(a) :: is_upper => psb_s_is_upper + procedure, pass(a) :: is_lower => psb_s_is_lower + procedure, pass(a) :: is_triangle => psb_s_is_triangle + procedure, pass(a) :: is_unit => psb_s_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_s_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_s_get_fmt + procedure, pass(a) :: sizeof => psb_s_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_s_set_nrows + procedure, pass(a) :: set_ncols => psb_s_set_ncols + procedure, pass(a) :: set_dupl => psb_s_set_dupl + procedure, pass(a) :: set_null => psb_s_set_null + procedure, pass(a) :: set_bld => psb_s_set_bld + procedure, pass(a) :: set_upd => psb_s_set_upd + procedure, pass(a) :: set_asb => psb_s_set_asb + procedure, pass(a) :: set_sorted => psb_s_set_sorted + procedure, pass(a) :: set_upper => psb_s_set_upper + procedure, pass(a) :: set_lower => psb_s_set_lower + procedure, pass(a) :: set_triangle => psb_s_set_triangle + procedure, pass(a) :: set_unit => psb_s_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_s_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_s_csall + procedure, pass(a) :: free => psb_s_free + procedure, pass(a) :: trim => psb_s_trim + procedure, pass(a) :: csput_a => psb_s_csput_a + procedure, pass(a) :: csput_v => psb_s_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_s_csgetptn + procedure, pass(a) :: csgetrow => psb_s_csgetrow + procedure, pass(a) :: csgetblk => psb_s_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: lcsgetptn => psb_s_lcsgetptn + procedure, pass(a) :: lcsgetrow => psb_s_lcsgetrow + generic, public :: csget => lcsgetptn, lcsgetrow +#endif + procedure, pass(a) :: tril => psb_s_tril + procedure, pass(a) :: triu => psb_s_triu + procedure, pass(a) :: m_csclip => psb_s_csclip + procedure, pass(a) :: b_csclip => psb_s_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_s_clean_zeros + procedure, pass(a) :: reall => psb_s_reallocate_nz + procedure, pass(a) :: get_neigh => psb_s_get_neigh + procedure, pass(a) :: reinit => psb_s_reinit + procedure, pass(a) :: print_i => psb_s_sparse_print + procedure, pass(a) :: print_n => psb_s_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_s_mold + procedure, pass(a) :: asb => psb_s_asb + procedure, pass(a) :: transp_1mat => psb_s_transp_1mat + procedure, pass(a) :: transp_2mat => psb_s_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_s_transc_1mat + procedure, pass(a) :: transc_2mat => psb_s_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => s_mat_sync + procedure, pass(a) :: is_host => s_mat_is_host + procedure, pass(a) :: is_dev => s_mat_is_dev + procedure, pass(a) :: is_sync => s_mat_is_sync + procedure, pass(a) :: set_host => s_mat_set_host + procedure, pass(a) :: set_dev => s_mat_set_dev + procedure, pass(a) :: set_sync => s_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_s_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_s_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_s_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_s_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: clip_d_ip => psb_s_clip_d_ip + procedure, pass(a) :: clip_d => psb_s_clip_d + generic, public :: clip_diag => clip_d_ip, clip_d + procedure, pass(a) :: cscnv_np => psb_s_cscnv + procedure, pass(a) :: cscnv_ip => psb_s_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_s_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_sspmat_clone + ! + ! To/from ls + ! + procedure, pass(a) :: mv_from_lb => psb_s_mv_from_lb + procedure, pass(a) :: mv_to_lb => psb_s_mv_to_lb + procedure, pass(a) :: cp_from_lb => psb_s_cp_from_lb + procedure, pass(a) :: cp_to_lb => psb_s_cp_to_lb + procedure, pass(a) :: mv_from_l => psb_s_mv_from_l + procedure, pass(a) :: mv_to_l => psb_s_mv_to_l + procedure, pass(a) :: cp_from_l => psb_s_cp_from_l + procedure, pass(a) :: cp_to_l => psb_s_cp_to_l + generic, public :: mv_from => mv_from_lb, mv_from_l + generic, public :: mv_to => mv_to_lb, mv_to_l + generic, public :: cp_from => cp_from_lb, cp_from_l + generic, public :: cp_to => cp_to_lb, cp_to_l + + ! Computational routines + procedure, pass(a) :: get_diag => psb_s_get_diag + procedure, pass(a) :: maxval => psb_s_maxval + procedure, pass(a) :: spnmi => psb_s_csnmi + procedure, pass(a) :: spnm1 => psb_s_csnm1 + procedure, pass(a) :: rowsum => psb_s_rowsum + procedure, pass(a) :: arwsum => psb_s_arwsum + procedure, pass(a) :: colsum => psb_s_colsum + procedure, pass(a) :: aclsum => psb_s_aclsum + procedure, pass(a) :: csmv_v => psb_s_csmv_vect + procedure, pass(a) :: csmv => psb_s_csmv + procedure, pass(a) :: csmm => psb_s_csmm + generic, public :: spmm => csmm, csmv, csmv_v + procedure, pass(a) :: scals => psb_s_scals + procedure, pass(a) :: scalv => psb_s_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: cssv_v => psb_s_cssv_vect + procedure, pass(a) :: cssv => psb_s_cssv + procedure, pass(a) :: cssm => psb_s_cssm + generic, public :: spsm => cssm, cssv, cssv_v + + end type psb_sspmat_type + + private :: psb_s_get_nrows, psb_s_get_ncols, & + & psb_s_get_nzeros, psb_s_get_size, & + & psb_s_get_dupl, psb_s_is_null, psb_s_is_bld, & + & psb_s_is_upd, psb_s_is_asb, psb_s_is_sorted, & + & psb_s_is_by_rows, psb_s_is_by_cols, psb_s_is_upper, & + & psb_s_is_lower, psb_s_is_triangle, psb_s_get_nz_row, & + & s_mat_sync, s_mat_is_host, s_mat_is_dev, & + & s_mat_is_sync, s_mat_set_host, s_mat_set_dev,& + & s_mat_set_sync + + + + class(psb_s_base_sparse_mat), allocatable, target, & + & save, private :: psb_s_base_mat_default + + interface psb_set_mat_default + module procedure psb_s_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_s_get_mat_default + end interface + + interface psb_sizeof + module procedure psb_s_sizeof + end interface + + + type :: psb_lsspmat_type + + class(psb_ls_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_ls_get_nrows + procedure, pass(a) :: get_ncols => psb_ls_get_ncols + procedure, pass(a) :: get_nzeros => psb_ls_get_nzeros + procedure, pass(a) :: get_nz_row => psb_ls_get_nz_row + procedure, pass(a) :: get_size => psb_ls_get_size + procedure, pass(a) :: get_dupl => psb_ls_get_dupl + procedure, pass(a) :: is_null => psb_ls_is_null + procedure, pass(a) :: is_bld => psb_ls_is_bld + procedure, pass(a) :: is_upd => psb_ls_is_upd + procedure, pass(a) :: is_asb => psb_ls_is_asb + procedure, pass(a) :: is_sorted => psb_ls_is_sorted + procedure, pass(a) :: is_by_rows => psb_ls_is_by_rows + procedure, pass(a) :: is_by_cols => psb_ls_is_by_cols + procedure, pass(a) :: is_upper => psb_ls_is_upper + procedure, pass(a) :: is_lower => psb_ls_is_lower + procedure, pass(a) :: is_triangle => psb_ls_is_triangle + procedure, pass(a) :: is_unit => psb_ls_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_ls_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_ls_get_fmt + procedure, pass(a) :: sizeof => psb_ls_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_ls_set_nrows + procedure, pass(a) :: set_ncols => psb_ls_set_ncols + procedure, pass(a) :: set_dupl => psb_ls_set_dupl + procedure, pass(a) :: set_null => psb_ls_set_null + procedure, pass(a) :: set_bld => psb_ls_set_bld + procedure, pass(a) :: set_upd => psb_ls_set_upd + procedure, pass(a) :: set_asb => psb_ls_set_asb + procedure, pass(a) :: set_sorted => psb_ls_set_sorted + procedure, pass(a) :: set_upper => psb_ls_set_upper + procedure, pass(a) :: set_lower => psb_ls_set_lower + procedure, pass(a) :: set_triangle => psb_ls_set_triangle + procedure, pass(a) :: set_unit => psb_ls_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_ls_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_ls_csall + procedure, pass(a) :: free => psb_ls_free + procedure, pass(a) :: trim => psb_ls_trim + procedure, pass(a) :: csput_a => psb_ls_csput_a + procedure, pass(a) :: csput_v => psb_ls_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_ls_csgetptn + procedure, pass(a) :: csgetrow => psb_ls_csgetrow + procedure, pass(a) :: csgetblk => psb_ls_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: icsgetptn => psb_ls_icsgetptn + procedure, pass(a) :: icsgetrow => psb_ls_icsgetrow + generic, public :: csget => icsgetptn, icsgetrow +#endif + procedure, pass(a) :: tril => psb_ls_tril + procedure, pass(a) :: triu => psb_ls_triu + procedure, pass(a) :: m_csclip => psb_ls_csclip + procedure, pass(a) :: b_csclip => psb_ls_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_ls_clean_zeros + procedure, pass(a) :: reall => psb_ls_reallocate_nz + procedure, pass(a) :: get_neigh => psb_ls_get_neigh + procedure, pass(a) :: reinit => psb_ls_reinit + procedure, pass(a) :: print_i => psb_ls_sparse_print + procedure, pass(a) :: print_n => psb_ls_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_ls_mold + procedure, pass(a) :: asb => psb_ls_asb + procedure, pass(a) :: transp_1mat => psb_ls_transp_1mat + procedure, pass(a) :: transp_2mat => psb_ls_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_ls_transc_1mat + procedure, pass(a) :: transc_2mat => psb_ls_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => ls_mat_sync + procedure, pass(a) :: is_host => ls_mat_is_host + procedure, pass(a) :: is_dev => ls_mat_is_dev + procedure, pass(a) :: is_sync => ls_mat_is_sync + procedure, pass(a) :: set_host => ls_mat_set_host + procedure, pass(a) :: set_dev => ls_mat_set_dev + procedure, pass(a) :: set_sync => ls_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_ls_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_ls_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_ls_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_ls_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: cscnv_np => psb_ls_cscnv + procedure, pass(a) :: cscnv_ip => psb_ls_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_ls_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_lsspmat_clone + ! + ! To/from s + ! + procedure, pass(a) :: mv_from_ib => psb_ls_mv_from_ib + procedure, pass(a) :: mv_to_ib => psb_ls_mv_to_ib + procedure, pass(a) :: cp_from_ib => psb_ls_cp_from_ib + procedure, pass(a) :: cp_to_ib => psb_ls_cp_to_ib + procedure, pass(a) :: mv_from_i => psb_ls_mv_from_i + procedure, pass(a) :: mv_to_i => psb_ls_mv_to_i + procedure, pass(a) :: cp_from_i => psb_ls_cp_from_i + procedure, pass(a) :: cp_to_i => psb_ls_cp_to_i + generic, public :: mv_from => mv_from_ib, mv_from_i + generic, public :: mv_to => mv_to_ib, mv_to_i + generic, public :: cp_from => cp_from_ib, cp_from_i + generic, public :: cp_to => cp_to_ib, cp_to_i + + ! Computational routines + procedure, pass(a) :: get_diag => psb_ls_get_diag + procedure, pass(a) :: maxval => psb_ls_maxval + procedure, pass(a) :: spnmi => psb_ls_csnmi + procedure, pass(a) :: spnm1 => psb_ls_csnm1 + procedure, pass(a) :: rowsum => psb_ls_rowsum + procedure, pass(a) :: arwsum => psb_ls_arwsum + procedure, pass(a) :: colsum => psb_ls_colsum + procedure, pass(a) :: aclsum => psb_ls_aclsum + procedure, pass(a) :: scals => psb_ls_scals + procedure, pass(a) :: scalv => psb_ls_scal + generic, public :: scal => scals, scalv + + end type psb_lsspmat_type + + private :: psb_ls_get_nrows, psb_ls_get_ncols, & + & psb_ls_get_nzeros, psb_ls_get_size, & + & psb_ls_get_dupl, psb_ls_is_null, psb_ls_is_bld, & + & psb_ls_is_upd, psb_ls_is_asb, psb_ls_is_sorted, & + & psb_ls_is_by_rows, psb_ls_is_by_cols, psb_ls_is_upper, & + & psb_ls_is_lower, psb_ls_is_triangle, psb_ls_get_nz_row, & + & ls_mat_sync, ls_mat_is_host, ls_mat_is_dev, & + & ls_mat_is_sync, ls_mat_set_host, ls_mat_set_dev,& + & ls_mat_set_sync + + + + class(psb_ls_base_sparse_mat), allocatable, target, & + & save, private :: psb_ls_base_mat_default + + interface psb_set_mat_default + module procedure psb_ls_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_ls_get_mat_default + end interface + + + ! == =================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == =================================== + + + interface + subroutine psb_s_set_nrows(m,a) + import :: psb_ipk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: m + end subroutine psb_s_set_nrows + end interface + + interface + subroutine psb_s_set_ncols(n,a) + import :: psb_ipk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_s_set_ncols + end interface + + interface + subroutine psb_s_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_s_set_dupl + end interface + + interface + subroutine psb_s_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_set_null + end interface + + interface + subroutine psb_s_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_set_bld + end interface + + interface + subroutine psb_s_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_set_upd + end interface + + interface + subroutine psb_s_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_set_asb + end interface + + interface + subroutine psb_s_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_sorted + end interface + + interface + subroutine psb_s_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_triangle + end interface + + interface + subroutine psb_s_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_unit + end interface + + interface + subroutine psb_s_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_lower + end interface + + interface + subroutine psb_s_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_s_set_upper + end interface + + interface + subroutine psb_s_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_s_sparse_print + end interface + + interface + subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + character(len=*), intent(in) :: fname + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_s_n_sparse_print + end interface + + interface + subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n + integer(psb_ipk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: lev + end subroutine psb_s_get_neigh + end interface + + interface + subroutine psb_s_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: nz + end subroutine psb_s_csall + end interface + + interface + subroutine psb_s_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + integer(psb_ipk_), intent(in) :: nz + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_reallocate_nz + end interface + + interface + subroutine psb_s_free(a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_free + end interface + + interface + subroutine psb_s_trim(a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_trim + end interface + + interface + subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_s_csput_a + end interface + + + interface + subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_vect_mod, only : psb_s_vect_type + use psb_i_vect_mod, only : psb_i_vect_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + type(psb_s_vect_type), intent(inout) :: val + type(psb_i_vect_type), intent(inout) :: ia, ja + integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_s_csput_v + end interface + + interface + subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csgetptn + end interface + + interface + subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csgetrow + end interface + + interface + subroutine psb_s_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csgetblk + end interface + + interface + subroutine psb_s_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_sspmat_type), optional, intent(inout) :: u + end subroutine psb_s_tril + end interface + + interface + subroutine psb_s_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_sspmat_type), optional, intent(inout) :: l + end subroutine psb_s_triu + end interface + + + interface + subroutine psb_s_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_csclip + end interface + + interface + subroutine psb_s_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_coo_sparse_mat + class(psb_sspmat_type), intent(in) :: a + type(psb_s_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_s_b_csclip + end interface + + interface + subroutine psb_s_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_s_mold + end interface + + interface + subroutine psb_s_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_s_asb + end interface + + interface + subroutine psb_s_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_transp_1mat + end interface + + interface + subroutine psb_s_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: b + end subroutine psb_s_transp_2mat + end interface + + interface + subroutine psb_s_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + end subroutine psb_s_transc_1mat + end interface + + interface + subroutine psb_s_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: b + end subroutine psb_s_transc_2mat + end interface + + interface + subroutine psb_s_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_s_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_s_cscnv + end interface + + + interface + subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_s_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_s_cscnv_ip + end interface + + + interface + subroutine psb_s_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(in) :: a + class(psb_s_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_s_cscnv_base + end interface + + ! + ! Produce a version of the matrix with diagonal cut + ! out; passes through a COO buffer. + ! + interface + subroutine psb_s_clip_d(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + end subroutine psb_s_clip_d + end interface + + interface + subroutine psb_s_clip_d_ip(a,info) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + end subroutine psb_s_clip_d_ip + end interface + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_s_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + end subroutine psb_s_mv_from + end interface + + interface + subroutine psb_s_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(out) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + end subroutine psb_s_cp_from + end interface + + interface + subroutine psb_s_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + end subroutine psb_s_mv_to + end interface + + interface + subroutine psb_s_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_sspmat_type), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + end subroutine psb_s_cp_to + end interface + ! + ! Mixed type conversions + ! + interface + subroutine psb_s_mv_from_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_sspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_s_mv_from_lb + end interface + + interface + subroutine psb_s_cp_from_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_sspmat_type), intent(out) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + end subroutine psb_s_cp_from_lb + end interface + + interface + subroutine psb_s_mv_to_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_sspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_s_mv_to_lb + end interface + + interface + subroutine psb_s_cp_to_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_sspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_s_cp_to_lb + end interface + + interface + subroutine psb_s_mv_from_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_lsspmat_type + class(psb_sspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + end subroutine psb_s_mv_from_l + end interface + + interface + subroutine psb_s_cp_from_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_lsspmat_type + class(psb_sspmat_type), intent(out) :: a + class(psb_lsspmat_type), intent(in) :: b + end subroutine psb_s_cp_from_l + end interface + + interface + subroutine psb_s_mv_to_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_lsspmat_type + class(psb_sspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + end subroutine psb_s_mv_to_l + end interface + + interface + subroutine psb_s_cp_to_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_lsspmat_type + class(psb_sspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + end subroutine psb_s_cp_to_l + end interface + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_sspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sspmat_type_move + end interface + + interface + subroutine psb_sspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sspmat_clone + end interface + + + + + ! == =================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + ! == =================================== + + interface psb_csmm + subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_csmm + subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_csmv + subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans) + use psb_s_vect_mod, only : psb_s_vect_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta + type(psb_s_vect_type), intent(inout) :: x + type(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_s_csmv_vect + end interface + + interface psb_cssm + subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:,:) + real(psb_spk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_s_cssm + subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta, x(:) + real(psb_spk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + real(psb_spk_), intent(in), optional :: d(:) + end subroutine psb_s_cssv + subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) + use psb_s_vect_mod, only : psb_s_vect_type + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), intent(in) :: alpha, beta + type(psb_s_vect_type), intent(inout) :: x + type(psb_s_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + type(psb_s_vect_type), optional, intent(inout) :: d + end subroutine psb_s_cssv_vect + end interface + + interface + function psb_s_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_s_maxval + end interface + + interface + function psb_s_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_s_csnmi + end interface + + interface + function psb_s_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_s_csnm1 + end interface + + interface + function psb_s_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_s_rowsum + end interface + + interface + function psb_s_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_s_arwsum + end interface + + interface + function psb_s_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_s_colsum + end interface + + interface + function psb_s_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_s_aclsum + end interface + + interface + function psb_s_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_s_get_diag + end interface + + interface psb_scal + subroutine psb_s_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_s_scal + subroutine psb_s_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_ + class(psb_sspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_scals + end interface + + + ! == =================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == =================================== + + + interface + subroutine psb_ls_set_nrows(m,a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + end subroutine psb_ls_set_nrows + end interface + + interface + subroutine psb_ls_set_ncols(n,a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + end subroutine psb_ls_set_ncols + end interface + + interface + subroutine psb_ls_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_ls_set_dupl + end interface + + interface + subroutine psb_ls_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_set_null + end interface + + interface + subroutine psb_ls_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_set_bld + end interface + + interface + subroutine psb_ls_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_set_upd + end interface + + interface + subroutine psb_ls_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_set_asb + end interface + + interface + subroutine psb_ls_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_sorted + end interface + + interface + subroutine psb_ls_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_triangle + end interface + + interface + subroutine psb_ls_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_unit + end interface + + interface + subroutine psb_ls_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_lower + end interface + + interface + subroutine psb_ls_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_ls_set_upper + end interface + + interface + subroutine psb_ls_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_sparse_print + end interface + + interface + subroutine psb_ls_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + character(len=*), intent(in) :: fname + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_ls_n_sparse_print + end interface + + interface + subroutine psb_ls_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_ls_get_neigh + end interface + + interface + subroutine psb_ls_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_ls_csall + end interface + + interface + subroutine psb_ls_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + integer(psb_lpk_), intent(in) :: nz + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_reallocate_nz + end interface + + interface + subroutine psb_ls_free(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_free + end interface + + interface + subroutine psb_ls_trim(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_trim + end interface + + interface + subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_csput_a + end interface + + + interface + subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_vect_mod, only : psb_s_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + type(psb_s_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_ls_csput_v + end interface + + interface + subroutine psb_ls_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csgetptn + end interface + + interface + subroutine psb_ls_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csgetrow + end interface + + interface + subroutine psb_ls_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csgetblk + end interface + + interface + subroutine psb_ls_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lsspmat_type), optional, intent(inout) :: u + end subroutine psb_ls_tril + end interface + + interface + subroutine psb_ls_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lsspmat_type), optional, intent(inout) :: l + end subroutine psb_ls_triu + end interface + + + interface + subroutine psb_ls_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_csclip + end interface + + interface + subroutine psb_ls_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_coo_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + type(psb_ls_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_ls_b_csclip + end interface + + interface + subroutine psb_ls_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_ls_mold + end interface + + interface + subroutine psb_ls_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_ls_asb + end interface + + interface + subroutine psb_ls_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_transp_1mat + end interface + + interface + subroutine psb_ls_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + end subroutine psb_ls_transp_2mat + end interface + + interface + subroutine psb_ls_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + end subroutine psb_ls_transc_1mat + end interface + + interface + subroutine psb_ls_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + end subroutine psb_ls_transc_2mat + end interface + + interface + subroutine psb_ls_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_ls_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_ls_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_ls_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_ls_cscnv + end interface + + + interface + subroutine psb_ls_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_ls_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_ls_cscnv_ip + end interface + + + interface + subroutine psb_ls_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_ls_cscnv_base + end interface + + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_ls_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_mv_from + end interface + + interface + subroutine psb_ls_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(out) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + end subroutine psb_ls_cp_from + end interface + + interface + subroutine psb_ls_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_mv_to + end interface + + interface + subroutine psb_ls_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_ls_base_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_cp_to + end interface + ! + ! Mixed type conversions + ! + interface + subroutine psb_ls_mv_from_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_mv_from_ib + end interface + + interface + subroutine psb_ls_cp_from_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_lsspmat_type), intent(out) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + end subroutine psb_ls_cp_from_ib + end interface + + interface + subroutine psb_ls_mv_to_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_lsspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_mv_to_ib + end interface + + interface + subroutine psb_ls_cp_to_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_s_base_sparse_mat + class(psb_lsspmat_type), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + end subroutine psb_ls_cp_to_ib + end interface + + interface + subroutine psb_ls_mv_from_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_sspmat_type + class(psb_lsspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + end subroutine psb_ls_mv_from_i + end interface + + interface + subroutine psb_ls_cp_from_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_sspmat_type + class(psb_lsspmat_type), intent(out) :: a + class(psb_sspmat_type), intent(in) :: b + end subroutine psb_ls_cp_from_i + end interface + + interface + subroutine psb_ls_mv_to_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_sspmat_type + class(psb_lsspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + end subroutine psb_ls_mv_to_i + end interface + + interface + subroutine psb_ls_cp_to_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_, psb_sspmat_type + class(psb_lsspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: b + end subroutine psb_ls_cp_to_i + end interface + + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_lsspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lsspmat_type_move + end interface + + interface + subroutine psb_lsspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lsspmat_clone + end interface + + + + interface + function psb_ls_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_get_diag + end interface + + interface psb_scal + subroutine psb_ls_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_ls_scal + subroutine psb_ls_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_ls_scals + end interface + + interface + function psb_ls_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_maxval + end interface + + interface + function psb_ls_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csnmi + end interface + + interface + function psb_ls_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + end function psb_ls_csnm1 + end interface + + interface + function psb_ls_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_rowsum + end interface + + interface + function psb_ls_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_arwsum + end interface + + interface + function psb_ls_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_colsum + end interface + + interface + function psb_ls_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lsspmat_type, psb_spk_ + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_ls_aclsum + end interface + +contains + + subroutine psb_s_set_mat_default(a) + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + + if (allocated(psb_s_base_mat_default)) then + deallocate(psb_s_base_mat_default) + end if + allocate(psb_s_base_mat_default, mold=a) + + end subroutine psb_s_set_mat_default + + function psb_s_get_mat_default(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + class(psb_s_base_sparse_mat), pointer :: res + + res => psb_s_get_base_mat_default() + + end function psb_s_get_mat_default + + + function psb_s_get_base_mat_default() result(res) + implicit none + class(psb_s_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_s_base_mat_default)) then + allocate(psb_s_csr_sparse_mat :: psb_s_base_mat_default) + end if + + res => psb_s_base_mat_default + + end function psb_s_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_s_sizeof(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_s_sizeof + + + function psb_s_get_fmt(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_s_get_fmt + + + function psb_s_get_dupl(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_s_get_dupl + + function psb_s_get_nrows(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_s_get_nrows + + function psb_s_get_ncols(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_s_get_ncols + + function psb_s_is_triangle(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_s_is_triangle + + function psb_s_is_unit(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_s_is_unit + + function psb_s_is_upper(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_s_is_upper + + function psb_s_is_lower(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_s_is_lower + + function psb_s_is_null(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_s_is_null + + function psb_s_is_bld(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_s_is_bld + + function psb_s_is_upd(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_s_is_upd + + function psb_s_is_asb(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_s_is_asb + + function psb_s_is_sorted(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_s_is_sorted + + function psb_s_is_by_rows(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_s_is_by_rows + + function psb_s_is_by_cols(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_s_is_by_cols + + + ! + subroutine s_mat_sync(a) + implicit none + class(psb_sspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine s_mat_sync + + ! + subroutine s_mat_set_host(a) + implicit none + class(psb_sspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine s_mat_set_host + + + ! + subroutine s_mat_set_dev(a) + implicit none + class(psb_sspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine s_mat_set_dev + + ! + subroutine s_mat_set_sync(a) + implicit none + class(psb_sspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine s_mat_set_sync + + ! + function s_mat_is_dev(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function s_mat_is_dev + + ! + function s_mat_is_host(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function s_mat_is_host + + ! + function s_mat_is_sync(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function s_mat_is_sync + + + function psb_s_is_repeatable_updates(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_s_is_repeatable_updates + + subroutine psb_s_set_repeatable_updates(a,val) + implicit none + class(psb_sspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_s_set_repeatable_updates + + + function psb_s_get_nzeros(a) result(res) + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_s_get_nzeros + + function psb_s_get_size(a) result(res) + + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_s_get_size + + + function psb_s_get_nz_row(idx,a) result(res) + implicit none + integer(psb_ipk_), intent(in) :: idx + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_s_get_nz_row + + subroutine psb_s_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_sspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_s_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_s_lcsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_s_lcsgetptn + + subroutine psb_s_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_sspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_s_lcsgetrow +#endif + + ! + ! ls methods + ! + + + subroutine psb_ls_set_mat_default(a) + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + + if (allocated(psb_ls_base_mat_default)) then + deallocate(psb_ls_base_mat_default) + end if + allocate(psb_ls_base_mat_default, mold=a) + + end subroutine psb_ls_set_mat_default + + function psb_ls_get_mat_default(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), pointer :: res + + res => psb_ls_get_base_mat_default() + + end function psb_ls_get_mat_default + + + function psb_ls_get_base_mat_default() result(res) + implicit none + class(psb_ls_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_ls_base_mat_default)) then + allocate(psb_ls_csr_sparse_mat :: psb_ls_base_mat_default) + end if + + res => psb_ls_base_mat_default + + end function psb_ls_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_ls_sizeof(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_ls_sizeof + + + function psb_ls_get_fmt(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_ls_get_fmt + + + function psb_ls_get_dupl(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_ls_get_dupl + + function psb_ls_get_nrows(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_ls_get_nrows + + function psb_ls_get_ncols(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_ls_get_ncols + + function psb_ls_is_triangle(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_ls_is_triangle + + function psb_ls_is_unit(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_ls_is_unit + + function psb_ls_is_upper(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_ls_is_upper + + function psb_ls_is_lower(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_ls_is_lower + + function psb_ls_is_null(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_ls_is_null + + function psb_ls_is_bld(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_ls_is_bld + + function psb_ls_is_upd(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_ls_is_upd + + function psb_ls_is_asb(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_ls_is_asb + + function psb_ls_is_sorted(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_ls_is_sorted + + function psb_ls_is_by_rows(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_ls_is_by_rows + + function psb_ls_is_by_cols(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_ls_is_by_cols + + + ! + subroutine ls_mat_sync(a) + implicit none + class(psb_lsspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine ls_mat_sync + + ! + subroutine ls_mat_set_host(a) + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine ls_mat_set_host + + + ! + subroutine ls_mat_set_dev(a) + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine ls_mat_set_dev + + ! + subroutine ls_mat_set_sync(a) + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine ls_mat_set_sync + + ! + function ls_mat_is_dev(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function ls_mat_is_dev + + ! + function ls_mat_is_host(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function ls_mat_is_host + + ! + function ls_mat_is_sync(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function ls_mat_is_sync + + + function psb_ls_is_repeatable_updates(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_ls_is_repeatable_updates + + subroutine psb_ls_set_repeatable_updates(a,val) + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_ls_set_repeatable_updates + + + function psb_ls_get_nzeros(a) result(res) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_ls_get_nzeros + + function psb_ls_get_size(a) result(res) + + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_ls_get_size + + + function psb_ls_get_nz_row(idx,a) result(res) + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_ls_get_nz_row + + subroutine psb_ls_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_lsspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_ls_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_ls_icsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_ls_icsgetptn + + subroutine psb_ls_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_ls_icsgetrow +#endif + +end module psb_s_mat_mod diff --git a/base/modules/serial/psb_s_mat_mod.f90 b/base/modules/serial/psb_s_mat_mod.f90 deleted file mode 100644 index 32b424b83..000000000 --- a/base/modules/serial/psb_s_mat_mod.f90 +++ /dev/null @@ -1,1296 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! package: psb_s_mat_mod -! -! This module contains the definition of the psb_s_sparse type which -! is a generic container for a sparse matrix and it is mostly meant to -! provide a mean of switching, at run-time, among different formats, -! potentially unknown at the library compile-time by adding a layer of -! indirection. This type encapsulates the psb_s_base_sparse_mat class -! inside another class which is the one visible to the user. -! Most methods of the psb_s_mat_mod simply call the methods of the -! encapsulated class. -! The exceptions are mainly cscnv and cp_from/cp_to; these provide -! the functionalities to have the encapsulated class change its -! type dynamically, and to extract/input an inner object. -! -! A sparse matrix has a state corresponding to its progression -! through the application life. -! In particular, computational methods can only be invoked when -! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the -! following state transition table. Associated with these states are -! the possible dynamic types of the inner matrix object. -! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method -!| ---------------------------------- -!| Null Build csall -!| Build Build csput -!| Build Assembled cscnv -!| Assembled Assembled cscnv -!| Assembled Update reinit -!| Update Update csput -!| Update Assembled cscnv -!| * unchanged reall -!| Assembled Null free -! - - -module psb_s_mat_mod - - use psb_s_base_mat_mod - use psb_s_csr_mat_mod, only : psb_s_csr_sparse_mat - use psb_s_csc_mat_mod, only : psb_s_csc_sparse_mat - - type :: psb_sspmat_type - - class(psb_s_base_sparse_mat), allocatable :: a - - contains - ! Getters - procedure, pass(a) :: get_nrows => psb_s_get_nrows - procedure, pass(a) :: get_ncols => psb_s_get_ncols - procedure, pass(a) :: get_nzeros => psb_s_get_nzeros - procedure, pass(a) :: get_nz_row => psb_s_get_nz_row - procedure, pass(a) :: get_size => psb_s_get_size - procedure, pass(a) :: get_dupl => psb_s_get_dupl - procedure, pass(a) :: is_null => psb_s_is_null - procedure, pass(a) :: is_bld => psb_s_is_bld - procedure, pass(a) :: is_upd => psb_s_is_upd - procedure, pass(a) :: is_asb => psb_s_is_asb - procedure, pass(a) :: is_sorted => psb_s_is_sorted - procedure, pass(a) :: is_by_rows => psb_s_is_by_rows - procedure, pass(a) :: is_by_cols => psb_s_is_by_cols - procedure, pass(a) :: is_upper => psb_s_is_upper - procedure, pass(a) :: is_lower => psb_s_is_lower - procedure, pass(a) :: is_triangle => psb_s_is_triangle - procedure, pass(a) :: is_unit => psb_s_is_unit - procedure, pass(a) :: is_repeatable_updates => psb_s_is_repeatable_updates - procedure, pass(a) :: get_fmt => psb_s_get_fmt - procedure, pass(a) :: sizeof => psb_s_sizeof - - ! Setters - procedure, pass(a) :: set_nrows => psb_s_set_nrows - procedure, pass(a) :: set_ncols => psb_s_set_ncols - procedure, pass(a) :: set_dupl => psb_s_set_dupl - procedure, pass(a) :: set_null => psb_s_set_null - procedure, pass(a) :: set_bld => psb_s_set_bld - procedure, pass(a) :: set_upd => psb_s_set_upd - procedure, pass(a) :: set_asb => psb_s_set_asb - procedure, pass(a) :: set_sorted => psb_s_set_sorted - procedure, pass(a) :: set_upper => psb_s_set_upper - procedure, pass(a) :: set_lower => psb_s_set_lower - procedure, pass(a) :: set_triangle => psb_s_set_triangle - procedure, pass(a) :: set_unit => psb_s_set_unit - procedure, pass(a) :: set_repeatable_updates => psb_s_set_repeatable_updates - - ! Memory/data management - procedure, pass(a) :: csall => psb_s_csall - procedure, pass(a) :: free => psb_s_free - procedure, pass(a) :: trim => psb_s_trim - procedure, pass(a) :: csput_a => psb_s_csput_a - procedure, pass(a) :: csput_v => psb_s_csput_v - generic, public :: csput => csput_a, csput_v - procedure, pass(a) :: csgetptn => psb_s_csgetptn - procedure, pass(a) :: csgetrow => psb_s_csgetrow - procedure, pass(a) :: csgetblk => psb_s_csgetblk - generic, public :: csget => csgetptn, csgetrow, csgetblk - procedure, pass(a) :: tril => psb_s_tril - procedure, pass(a) :: triu => psb_s_triu - procedure, pass(a) :: m_csclip => psb_s_csclip - procedure, pass(a) :: b_csclip => psb_s_b_csclip - generic, public :: csclip => b_csclip, m_csclip - procedure, pass(a) :: clean_zeros => psb_s_clean_zeros - procedure, pass(a) :: reall => psb_s_reallocate_nz - procedure, pass(a) :: get_neigh => psb_s_get_neigh - procedure, pass(a) :: reinit => psb_s_reinit - procedure, pass(a) :: print_i => psb_s_sparse_print - procedure, pass(a) :: print_n => psb_s_n_sparse_print - generic, public :: print => print_i, print_n - procedure, pass(a) :: mold => psb_s_mold - procedure, pass(a) :: asb => psb_s_asb - procedure, pass(a) :: transp_1mat => psb_s_transp_1mat - procedure, pass(a) :: transp_2mat => psb_s_transp_2mat - generic, public :: transp => transp_1mat, transp_2mat - procedure, pass(a) :: transc_1mat => psb_s_transc_1mat - procedure, pass(a) :: transc_2mat => psb_s_transc_2mat - generic, public :: transc => transc_1mat, transc_2mat - - ! - ! Sync: centerpiece of handling of external storage. - ! Any derived class having extra storage upon sync - ! will guarantee that both fortran/host side and - ! external side contain the same data. The base - ! version is only a placeholder. - ! - procedure, pass(a) :: sync => s_mat_sync - procedure, pass(a) :: is_host => s_mat_is_host - procedure, pass(a) :: is_dev => s_mat_is_dev - procedure, pass(a) :: is_sync => s_mat_is_sync - procedure, pass(a) :: set_host => s_mat_set_host - procedure, pass(a) :: set_dev => s_mat_set_dev - procedure, pass(a) :: set_sync => s_mat_set_sync - - - ! These are specific to this level of encapsulation. - procedure, pass(a) :: mv_from_b => psb_s_mv_from - generic, public :: mv_from => mv_from_b - procedure, pass(a) :: mv_to_b => psb_s_mv_to - generic, public :: mv_to => mv_to_b - procedure, pass(a) :: cp_from_b => psb_s_cp_from - generic, public :: cp_from => cp_from_b - procedure, pass(a) :: cp_to_b => psb_s_cp_to - generic, public :: cp_to => cp_to_b - procedure, pass(a) :: clip_d_ip => psb_s_clip_d_ip - procedure, pass(a) :: clip_d => psb_s_clip_d - generic, public :: clip_diag => clip_d_ip, clip_d - procedure, pass(a) :: cscnv_np => psb_s_cscnv - procedure, pass(a) :: cscnv_ip => psb_s_cscnv_ip - procedure, pass(a) :: cscnv_base => psb_s_cscnv_base - generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base - procedure, pass(a) :: clone => psb_sspmat_clone - - ! Computational routines - procedure, pass(a) :: get_diag => psb_s_get_diag - procedure, pass(a) :: maxval => psb_s_maxval - procedure, pass(a) :: spnmi => psb_s_csnmi - procedure, pass(a) :: spnm1 => psb_s_csnm1 - procedure, pass(a) :: rowsum => psb_s_rowsum - procedure, pass(a) :: arwsum => psb_s_arwsum - procedure, pass(a) :: colsum => psb_s_colsum - procedure, pass(a) :: aclsum => psb_s_aclsum - procedure, pass(a) :: csmv_v => psb_s_csmv_vect - procedure, pass(a) :: csmv => psb_s_csmv - procedure, pass(a) :: csmm => psb_s_csmm - generic, public :: spmm => csmm, csmv, csmv_v - procedure, pass(a) :: scals => psb_s_scals - procedure, pass(a) :: scalv => psb_s_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: cssv_v => psb_s_cssv_vect - procedure, pass(a) :: cssv => psb_s_cssv - procedure, pass(a) :: cssm => psb_s_cssm - generic, public :: spsm => cssm, cssv, cssv_v - - end type psb_sspmat_type - - private :: psb_s_get_nrows, psb_s_get_ncols, & - & psb_s_get_nzeros, psb_s_get_size, & - & psb_s_get_dupl, psb_s_is_null, psb_s_is_bld, & - & psb_s_is_upd, psb_s_is_asb, psb_s_is_sorted, & - & psb_s_is_by_rows, psb_s_is_by_cols, psb_s_is_upper, & - & psb_s_is_lower, psb_s_is_triangle, psb_s_get_nz_row, & - & s_mat_sync, s_mat_is_host, s_mat_is_dev, & - & s_mat_is_sync, s_mat_set_host, s_mat_set_dev,& - & s_mat_set_sync - - - - class(psb_s_base_sparse_mat), allocatable, target, & - & save, private :: psb_s_base_mat_default - - interface psb_set_mat_default - module procedure psb_s_set_mat_default - end interface - - interface psb_get_mat_default - module procedure psb_s_get_mat_default - end interface - - interface psb_sizeof - module procedure psb_s_sizeof - end interface - - - ! == =================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - ! == =================================== - - - interface - subroutine psb_s_set_nrows(m,a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: m - end subroutine psb_s_set_nrows - end interface - - interface - subroutine psb_s_set_ncols(n,a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_s_set_ncols - end interface - - interface - subroutine psb_s_set_dupl(n,a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_s_set_dupl - end interface - - interface - subroutine psb_s_set_null(a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_set_null - end interface - - interface - subroutine psb_s_set_bld(a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_set_bld - end interface - - interface - subroutine psb_s_set_upd(a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_set_upd - end interface - - interface - subroutine psb_s_set_asb(a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_set_asb - end interface - - interface - subroutine psb_s_set_sorted(a,val) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_s_set_sorted - end interface - - interface - subroutine psb_s_set_triangle(a,val) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_s_set_triangle - end interface - - interface - subroutine psb_s_set_unit(a,val) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_s_set_unit - end interface - - interface - subroutine psb_s_set_lower(a,val) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_s_set_lower - end interface - - interface - subroutine psb_s_set_upper(a,val) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_s_set_upper - end interface - - interface - subroutine psb_s_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_sspmat_type - integer(psb_ipk_), intent(in) :: iout - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_s_sparse_print - end interface - - interface - subroutine psb_s_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_sspmat_type - character(len=*), intent(in) :: fname - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_s_n_sparse_print - end interface - - interface - subroutine psb_s_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n - integer(psb_ipk_), allocatable, intent(out) :: neigh(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev - end subroutine psb_s_get_neigh - end interface - - interface - subroutine psb_s_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nr,nc - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: nz - end subroutine psb_s_csall - end interface - - interface - subroutine psb_s_reallocate_nz(nz,a) - import :: psb_ipk_, psb_sspmat_type - integer(psb_ipk_), intent(in) :: nz - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_reallocate_nz - end interface - - interface - subroutine psb_s_free(a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_free - end interface - - interface - subroutine psb_s_trim(a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_trim - end interface - - interface - subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(inout) :: a - real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_s_csput_a - end interface - - - interface - subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_s_vect_mod, only : psb_s_vect_type - use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - type(psb_s_vect_type), intent(inout) :: val - type(psb_i_vect_type), intent(inout) :: ia, ja - integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_s_csput_v - end interface - - interface - subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_s_csgetptn - end interface - - interface - subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale,chksz - end subroutine psb_s_csgetrow - end interface - - interface - subroutine psb_s_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - class(psb_sspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_s_csgetblk - end interface - - interface - subroutine psb_s_tril(a,l,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - class(psb_sspmat_type), intent(inout) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_sspmat_type), optional, intent(inout) :: u - end subroutine psb_s_tril - end interface - - interface - subroutine psb_s_triu(a,u,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - class(psb_sspmat_type), intent(inout) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_sspmat_type), optional, intent(inout) :: l - end subroutine psb_s_triu - end interface - - - interface - subroutine psb_s_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - class(psb_sspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_s_csclip - end interface - - interface - subroutine psb_s_b_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_coo_sparse_mat - class(psb_sspmat_type), intent(in) :: a - type(psb_s_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_s_b_csclip - end interface - - interface - subroutine psb_s_mold(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(inout) :: a - class(psb_s_base_sparse_mat), allocatable, intent(out) :: b - end subroutine psb_s_mold - end interface - - interface - subroutine psb_s_asb(a,mold) - import :: psb_ipk_, psb_sspmat_type, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(inout) :: a - class(psb_s_base_sparse_mat), optional, intent(in) :: mold - end subroutine psb_s_asb - end interface - - interface - subroutine psb_s_transp_1mat(a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_transp_1mat - end interface - - interface - subroutine psb_s_transp_2mat(a,b) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(in) :: a - class(psb_sspmat_type), intent(inout) :: b - end subroutine psb_s_transp_2mat - end interface - - interface - subroutine psb_s_transc_1mat(a) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - end subroutine psb_s_transc_1mat - end interface - - interface - subroutine psb_s_transc_2mat(a,b) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(in) :: a - class(psb_sspmat_type), intent(inout) :: b - end subroutine psb_s_transc_2mat - end interface - - interface - subroutine psb_s_reinit(a,clear) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_s_reinit - - end interface - - - ! - ! These methods are specific to the outer SPMAT_TYPE level, since - ! they tamper with the inner BASE_SPARSE_MAT object. - ! - ! - - ! - ! CSCNV: switches to a different internal derived type. - ! 3 versions: copying to target - ! copying to a base_sparse_mat object. - ! in place - ! - ! - interface - subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(in) :: a - class(psb_sspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_s_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_s_cscnv - end interface - - - interface - subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(out) :: iinfo - integer(psb_ipk_),optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_s_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_s_cscnv_ip - end interface - - - interface - subroutine psb_s_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl - end subroutine psb_s_cscnv_base - end interface - - ! - ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. - ! - interface - subroutine psb_s_clip_d(a,b,info) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(in) :: a - class(psb_sspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - end subroutine psb_s_clip_d - end interface - - interface - subroutine psb_s_clip_d_ip(a,info) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info - end subroutine psb_s_clip_d_ip - end interface - - ! - ! These four interfaces cut through the - ! encapsulation between spmat_type and base_sparse_mat. - ! - interface - subroutine psb_s_mv_from(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - end subroutine psb_s_mv_from - end interface - - interface - subroutine psb_s_cp_from(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(out) :: a - class(psb_s_base_sparse_mat), intent(in) :: b - end subroutine psb_s_cp_from - end interface - - interface - subroutine psb_s_mv_to(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(inout) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - end subroutine psb_s_mv_to - end interface - - interface - subroutine psb_s_cp_to(a,b) - import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat - class(psb_sspmat_type), intent(in) :: a - class(psb_s_base_sparse_mat), intent(inout) :: b - end subroutine psb_s_cp_to - end interface - - ! - ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc - subroutine psb_sspmat_type_move(a,b,info) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - class(psb_sspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_sspmat_type_move - end interface - - interface - subroutine psb_sspmat_clone(a,b,info) - import :: psb_ipk_, psb_sspmat_type - class(psb_sspmat_type), intent(inout) :: a - class(psb_sspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_sspmat_clone - end interface - - - - - ! == =================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - ! == =================================== - - interface psb_csmm - subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_s_csmm - subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_s_csmv - subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans) - use psb_s_vect_mod, only : psb_s_vect_type - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta - type(psb_s_vect_type), intent(inout) :: x - type(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_s_csmv_vect - end interface - - interface psb_cssm - subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:,:) - real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - end subroutine psb_s_cssm - subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta, x(:) - real(psb_spk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - real(psb_spk_), intent(in), optional :: d(:) - end subroutine psb_s_cssv - subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) - use psb_s_vect_mod, only : psb_s_vect_type - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), intent(in) :: alpha, beta - type(psb_s_vect_type), intent(inout) :: x - type(psb_s_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - type(psb_s_vect_type), optional, intent(inout) :: d - end subroutine psb_s_cssv_vect - end interface - - interface - function psb_s_maxval(a) result(res) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_) :: res - end function psb_s_maxval - end interface - - interface - function psb_s_csnmi(a) result(res) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_) :: res - end function psb_s_csnmi - end interface - - interface - function psb_s_csnm1(a) result(res) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_) :: res - end function psb_s_csnm1 - end interface - - interface - function psb_s_rowsum(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_s_rowsum - end interface - - interface - function psb_s_arwsum(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_s_arwsum - end interface - - interface - function psb_s_colsum(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_s_colsum - end interface - - interface - function psb_s_aclsum(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_s_aclsum - end interface - - interface - function psb_s_get_diag(a,info) result(d) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(in) :: a - real(psb_spk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_s_get_diag - end interface - - interface psb_scal - subroutine psb_s_scal(d,a,info,side) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(inout) :: a - real(psb_spk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_s_scal - subroutine psb_s_scals(d,a,info) - import :: psb_ipk_, psb_sspmat_type, psb_spk_ - class(psb_sspmat_type), intent(inout) :: a - real(psb_spk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_s_scals - end interface - - -contains - - - - subroutine psb_s_set_mat_default(a) - implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - - if (allocated(psb_s_base_mat_default)) then - deallocate(psb_s_base_mat_default) - end if - allocate(psb_s_base_mat_default, mold=a) - - end subroutine psb_s_set_mat_default - - function psb_s_get_mat_default(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - class(psb_s_base_sparse_mat), pointer :: res - - res => psb_s_get_base_mat_default() - - end function psb_s_get_mat_default - - - function psb_s_get_base_mat_default() result(res) - implicit none - class(psb_s_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_s_base_mat_default)) then - allocate(psb_s_csr_sparse_mat :: psb_s_base_mat_default) - end if - - res => psb_s_base_mat_default - - end function psb_s_get_base_mat_default - - - - - ! == =================================== - ! - ! - ! - ! Getters - ! - ! - ! - ! - ! - ! == =================================== - - - function psb_s_sizeof(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - integer(psb_long_int_k_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_s_sizeof - - - function psb_s_get_fmt(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - character(len=5) :: res - - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' - end if - - end function psb_s_get_fmt - - - function psb_s_get_dupl(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_dupl() - else - res = psb_invalid_ - end if - end function psb_s_get_dupl - - function psb_s_get_nrows(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_nrows() - else - res = 0 - end if - - end function psb_s_get_nrows - - function psb_s_get_ncols(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_ncols() - else - res = 0 - end if - - end function psb_s_get_ncols - - function psb_s_is_triangle(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_triangle() - else - res = .false. - end if - - end function psb_s_is_triangle - - function psb_s_is_unit(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_unit() - else - res = .false. - end if - - end function psb_s_is_unit - - function psb_s_is_upper(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upper() - else - res = .false. - end if - - end function psb_s_is_upper - - function psb_s_is_lower(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = .not. a%a%is_upper() - else - res = .false. - end if - - end function psb_s_is_lower - - function psb_s_is_null(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_null() - else - res = .true. - end if - - end function psb_s_is_null - - function psb_s_is_bld(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_bld() - else - res = .false. - end if - - end function psb_s_is_bld - - function psb_s_is_upd(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upd() - else - res = .false. - end if - - end function psb_s_is_upd - - function psb_s_is_asb(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_asb() - else - res = .false. - end if - - end function psb_s_is_asb - - function psb_s_is_sorted(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_sorted() - else - res = .false. - end if - - end function psb_s_is_sorted - - function psb_s_is_by_rows(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_rows() - else - res = .false. - end if - - end function psb_s_is_by_rows - - function psb_s_is_by_cols(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_cols() - else - res = .false. - end if - - end function psb_s_is_by_cols - - - ! - subroutine s_mat_sync(a) - implicit none - class(psb_sspmat_type), target, intent(in) :: a - - if (allocated(a%a)) call a%a%sync() - - end subroutine s_mat_sync - - ! - subroutine s_mat_set_host(a) - implicit none - class(psb_sspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_host() - - end subroutine s_mat_set_host - - - ! - subroutine s_mat_set_dev(a) - implicit none - class(psb_sspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_dev() - - end subroutine s_mat_set_dev - - ! - subroutine s_mat_set_sync(a) - implicit none - class(psb_sspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_sync() - - end subroutine s_mat_set_sync - - ! - function s_mat_is_dev(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_dev() - else - res = .false. - end if - end function s_mat_is_dev - - ! - function s_mat_is_host(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_host() - else - res = .true. - end if - end function s_mat_is_host - - ! - function s_mat_is_sync(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_sync() - else - res = .true. - end if - - end function s_mat_is_sync - - - function psb_s_is_repeatable_updates(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_repeatable_updates() - else - res = .false. - end if - - end function psb_s_is_repeatable_updates - - subroutine psb_s_set_repeatable_updates(a,val) - implicit none - class(psb_sspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - - if (allocated(a%a)) then - call a%a%set_repeatable_updates(val) - end if - - end subroutine psb_s_set_repeatable_updates - - - function psb_s_get_nzeros(a) result(res) - implicit none - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%get_nzeros() - end if - - end function psb_s_get_nzeros - - function psb_s_get_size(a) result(res) - - implicit none - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - - res = 0 - if (allocated(a%a)) then - res = a%a%get_size() - end if - - end function psb_s_get_size - - - function psb_s_get_nz_row(idx,a) result(res) - implicit none - integer(psb_ipk_), intent(in) :: idx - class(psb_sspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - - if (allocated(a%a)) res = a%a%get_nz_row(idx) - - end function psb_s_get_nz_row - - subroutine psb_s_clean_zeros(a,info) - implicit none - integer(psb_ipk_), intent(out) :: info - class(psb_sspmat_type), intent(inout) :: a - - info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) - - end subroutine psb_s_clean_zeros - - -end module psb_s_mat_mod diff --git a/base/modules/serial/psb_s_serial_mod.f90 b/base/modules/serial/psb_s_serial_mod.f90 index 902d06f94..45ed7dbbe 100644 --- a/base/modules/serial/psb_s_serial_mod.f90 +++ b/base/modules/serial/psb_s_serial_mod.f90 @@ -119,9 +119,9 @@ module psb_s_serial_mod use psb_s_mat_mod, only : psb_sspmat_type import :: psb_ipk_ implicit none - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr type(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info type(psb_sspmat_type), intent(in), optional :: b logical,intent(in), optional :: rowscale end subroutine psb_srwextd @@ -129,12 +129,32 @@ module psb_s_serial_mod use psb_s_mat_mod, only : psb_s_base_sparse_mat import :: psb_ipk_ implicit none - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr class(psb_s_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: b logical,intent(in), optional :: rowscale end subroutine psb_sbase_rwextd + subroutine psb_lsrwextd(nr,a,info,b,rowscale) + use psb_s_mat_mod, only : psb_lsspmat_type + import :: psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: nr + type(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + type(psb_lsspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + end subroutine psb_lsrwextd + subroutine psb_lsbase_rwextd(nr,a,info,b,rowscale) + use psb_s_mat_mod, only : psb_ls_base_sparse_mat + import :: psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: nr + class(psb_ls_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + class(psb_ls_base_sparse_mat), intent(in), optional :: b + logical,intent(in), optional :: rowscale + end subroutine psb_lsbase_rwextd end interface psb_rwextd @@ -203,6 +223,69 @@ module psb_s_serial_mod end subroutine psb_s_aspxpby end interface psb_aspxpby + interface psb_spspmm + subroutine psb_lsspspmm(a,b,c,info) + use psb_s_mat_mod, only : psb_lsspmat_type + import :: psb_ipk_ + implicit none + type(psb_lsspmat_type), intent(in) :: a,b + type(psb_lsspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lsspspmm + subroutine psb_lscsrspspmm(a,b,c,info) + use psb_s_mat_mod, only : psb_ls_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lscsrspspmm + subroutine psb_lscscspspmm(a,b,c,info) + use psb_s_mat_mod, only : psb_ls_csc_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a,b + type(psb_ls_csc_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lscscspspmm + end interface psb_spspmm + + interface psb_symbmm + subroutine psb_lssymbmm(a,b,c,info) + use psb_s_mat_mod, only : psb_lsspmat_type + import :: psb_ipk_ + implicit none + type(psb_lsspmat_type), intent(in) :: a,b + type(psb_lsspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lssymbmm + subroutine psb_lsbase_symbmm(a,b,c,info) + use psb_s_mat_mod, only : psb_ls_base_sparse_mat, psb_ls_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lsbase_symbmm + end interface psb_symbmm + + interface psb_numbmm + subroutine psb_lsnumbmm(a,b,c) + use psb_s_mat_mod, only : psb_lsspmat_type + import :: psb_ipk_ + implicit none + type(psb_lsspmat_type), intent(in) :: a,b + type(psb_lsspmat_type), intent(inout) :: c + end subroutine psb_lsnumbmm + subroutine psb_lsbase_numbmm(a,b,c) + use psb_s_mat_mod, only : psb_ls_base_sparse_mat, psb_ls_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(inout) :: c + end subroutine psb_lsbase_numbmm + end interface psb_numbmm + contains subroutine psb_scsprt(iout,a,iv,head,ivr,ivc) diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index e3e3fe3df..0907f06ed 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -62,8 +62,9 @@ module psb_s_vect_mod procedure, pass(x) :: ins_v => s_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => s_vect_bld_x - procedure, pass(x) :: bld_n => s_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => s_vect_bld_mn + procedure, pass(x) :: bld_en => s_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => s_vect_get_vect procedure, pass(x) :: cnv => s_vect_cnv procedure, pass(x) :: set_scal => s_vect_set_scal @@ -112,7 +113,8 @@ module psb_s_vect_mod & s_vect_all, s_vect_reall, s_vect_zero, s_vect_asb, & & s_vect_gthab, s_vect_gthzv, s_vect_sctb, & & s_vect_free, s_vect_ins_a, s_vect_ins_v, s_vect_bld_x, & - & s_vect_bld_n, s_vect_get_vect, s_vect_cnv, s_vect_set_scal, & + & s_vect_bld_mn, s_vect_bld_en, s_vect_get_vect, & + & s_vect_cnv, s_vect_set_scal, & & s_vect_set_vect, s_vect_clone, s_vect_sync, s_vect_is_host, & & s_vect_is_dev, s_vect_is_sync, s_vect_set_host, & & s_vect_set_dev, s_vect_set_sync @@ -207,8 +209,8 @@ contains end subroutine s_vect_bld_x - subroutine s_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine s_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_s_vect_type), intent(inout) :: x class(psb_s_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -225,7 +227,28 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine s_vect_bld_n + end subroutine s_vect_bld_mn + + + subroutine s_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_s_vect_type), intent(inout) :: x + class(psb_s_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + + info = psb_success_ + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_s_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine s_vect_bld_en function s_vect_get_vect(x,n) result(res) class(psb_s_vect_type), intent(inout) :: x @@ -291,7 +314,7 @@ contains function s_vect_sizeof(x) result(res) implicit none class(psb_s_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function s_vect_sizeof @@ -1014,7 +1037,7 @@ contains function s_vect_sizeof(x) result(res) implicit none class(psb_s_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function s_vect_sizeof diff --git a/base/modules/serial/psb_serial_mod.f90 b/base/modules/serial/psb_serial_mod.f90 index e46ee807d..2f2154e0e 100644 --- a/base/modules/serial/psb_serial_mod.f90 +++ b/base/modules/serial/psb_serial_mod.f90 @@ -68,7 +68,7 @@ module psb_serial_mod end subroutine psb_d_nspaxpby end interface psb_nspaxpby - interface symbmm + interface subroutine symbmm (n, m, l, ia, ja, diaga, & & ib, jb, diagb, ic, jc, diagc, index) import :: psb_ipk_ @@ -76,6 +76,13 @@ module psb_serial_mod & diagc, index(*) integer(psb_ipk_), allocatable :: ic(:),jc(:) end subroutine symbmm + subroutine lsymbmm (n, m, l, ia, ja, diaga, & + & ib, jb, diagb, ic, jc, diagc, index) + import :: psb_ipk_, psb_lpk_ + integer(psb_lpk_) :: n,m,l, ia(*), ja(*), diaga, ib(*), jb(*), diagb,& + & diagc, index(*) + integer(psb_lpk_), allocatable :: ic(:),jc(:) + end subroutine lsymbmm end interface @@ -138,7 +145,7 @@ contains ! october 31, 1992 ! ! .. scalar arguments .. - integer(psb_mpik_) :: incx, incy, n + integer(psb_mpk_) :: incx, incy, n real(psb_spk_) c complex(psb_spk_) s ! .. @@ -182,7 +189,7 @@ contains ! == = ================================================================== ! ! .. local scalars .. - integer(psb_mpik_) :: i, ix, iy + integer(psb_mpk_) :: i, ix, iy complex(psb_spk_) stemp ! .. ! .. intrinsic functions .. @@ -256,7 +263,7 @@ contains ! october 31, 1992 ! ! .. scalar arguments .. - integer(psb_mpik_) :: incx, incy, n + integer(psb_mpk_) :: incx, incy, n real(psb_dpk_) c complex(psb_dpk_) s ! .. @@ -300,7 +307,7 @@ contains ! == = ================================================================== ! ! .. local scalars .. - integer(psb_mpik_) :: i, ix, iy + integer(psb_mpk_) :: i, ix, iy complex(psb_dpk_) stemp ! .. ! .. intrinsic functions .. diff --git a/base/modules/serial/psb_vect_mod.f90 b/base/modules/serial/psb_vect_mod.f90 index 3c2b5a807..64a33832a 100644 --- a/base/modules/serial/psb_vect_mod.f90 +++ b/base/modules/serial/psb_vect_mod.f90 @@ -1,10 +1,12 @@ module psb_vect_mod - use psb_i_vect_mod + use psb_i_vect_mod + use psb_l_vect_mod use psb_s_vect_mod use psb_d_vect_mod use psb_c_vect_mod use psb_z_vect_mod use psb_i_multivect_mod + use psb_l_multivect_mod use psb_s_multivect_mod use psb_d_multivect_mod use psb_c_multivect_mod @@ -19,12 +21,14 @@ contains ! type(psb_i_base_vect_type) :: ivetdef + type(psb_l_base_vect_type) :: lvetdef type(psb_s_base_vect_type) :: svetdef type(psb_d_base_vect_type) :: dvetdef type(psb_c_base_vect_type) :: cvetdef type(psb_z_base_vect_type) :: zvetdef call psb_set_vect_default(ivetdef) + call psb_set_vect_default(lvetdef) call psb_set_vect_default(svetdef) call psb_set_vect_default(dvetdef) call psb_set_vect_default(cvetdef) diff --git a/base/modules/serial/psb_z_base_mat_mod.f90 b/base/modules/serial/psb_z_base_mat_mod.f90 index e4caa1a87..f09b15f94 100644 --- a/base/modules/serial/psb_z_base_mat_mod.f90 +++ b/base/modules/serial/psb_z_base_mat_mod.f90 @@ -79,6 +79,18 @@ module psb_z_base_mat_mod procedure, pass(a) :: clone => psb_z_base_clone procedure, pass(a) :: make_nonunit => psb_z_base_make_nonunit procedure, pass(a) :: clean_zeros => psb_z_base_clean_zeros + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_lcoo => psb_z_base_cp_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_z_base_cp_from_lcoo + procedure, pass(a) :: cp_to_lfmt => psb_z_base_cp_to_lfmt + procedure, pass(a) :: cp_from_lfmt => psb_z_base_cp_from_lfmt + procedure, pass(a) :: mv_to_lcoo => psb_z_base_mv_to_lcoo + procedure, pass(a) :: mv_from_lcoo => psb_z_base_mv_from_lcoo + procedure, pass(a) :: mv_to_lfmt => psb_z_base_mv_to_lfmt + procedure, pass(a) :: mv_from_lfmt => psb_z_base_mv_from_lfmt + ! ! Transpose methods: defined here but not implemented. @@ -115,7 +127,10 @@ module psb_z_base_mat_mod procedure, pass(a) :: aclsum => psb_z_base_aclsum end type psb_z_base_sparse_mat - + private :: z_base_mat_sync, z_base_mat_is_host, z_base_mat_is_dev, & + & z_base_mat_is_sync, z_base_mat_set_host, z_base_mat_set_dev,& + & z_base_mat_set_sync + !> \namespace psb_base_mod \class psb_z_coo_sparse_mat !! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat !! @@ -155,6 +170,13 @@ module psb_z_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_z_mv_coo_from_coo procedure, pass(a) :: mv_to_fmt => psb_z_mv_coo_to_fmt procedure, pass(a) :: mv_from_fmt => psb_z_mv_coo_from_fmt + + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_lcoo => psb_z_cp_coo_to_lcoo + procedure, pass(a) :: cp_from_lcoo => psb_z_cp_coo_from_lcoo + procedure, pass(a) :: csput_a => psb_z_coo_csput_a procedure, pass(a) :: get_diag => psb_z_coo_get_diag procedure, pass(a) :: csgetrow => psb_z_coo_csgetrow @@ -212,6 +234,183 @@ module psb_z_base_mat_mod & z_coo_transp_1mat, z_coo_transc_1mat + !> \namespace psb_base_mod \class psb_lz_base_sparse_mat + !! \extends psb_lbase_mat_mod::psb_lbase_sparse_mat + !! The psb_lz_base_sparse_mat type, extending psb_base_sparse_mat, + !! defines a middle level complex(psb_dpk_) sparse matrix object. + !! This class object itself does not have any additional members + !! with respect to those of the base class. Most methods cannot be fully + !! implemented at this level, but we can define the interface for the + !! computational methods requiring the knowledge of the underlying + !! field, such as the matrix-vector product; this interface is defined, + !! but is supposed to be overridden at the leaf level. + !! + !! About the method MOLD: this has been defined for those compilers + !! not yet supporting ALLOCATE( ...,MOLD=...); it's otherwise silly to + !! duplicate "by hand" what is specified in the language (in this case F2008) + !! + type, extends(psb_lbase_sparse_mat) :: psb_lz_base_sparse_mat + contains + ! + ! Data management methods: defined here, but (mostly) not implemented. + ! + procedure, pass(a) :: csput_a => psb_lz_base_csput_a + procedure, pass(a) :: csput_v => psb_lz_base_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetrow => psb_lz_base_csgetrow + procedure, pass(a) :: csgetblk => psb_lz_base_csgetblk + procedure, pass(a) :: get_diag => psb_lz_base_get_diag + generic, public :: csget => csgetrow, csgetblk + procedure, pass(a) :: tril => psb_lz_base_tril + procedure, pass(a) :: triu => psb_lz_base_triu + procedure, pass(a) :: csclip => psb_lz_base_csclip + procedure, pass(a) :: cp_to_coo => psb_lz_base_cp_to_coo + procedure, pass(a) :: cp_from_coo => psb_lz_base_cp_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lz_base_cp_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lz_base_cp_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lz_base_mv_to_coo + procedure, pass(a) :: mv_from_coo => psb_lz_base_mv_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lz_base_mv_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lz_base_mv_from_fmt + procedure, pass(a) :: mold => psb_lz_base_mold + procedure, pass(a) :: clone => psb_lz_base_clone + procedure, pass(a) :: make_nonunit => psb_lz_base_make_nonunit + procedure, pass(a) :: clean_zeros => psb_lz_base_clean_zeros + + ! + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_lz_base_scals + procedure, pass(a) :: scalv => psb_lz_base_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: maxval => psb_lz_base_maxval + procedure, pass(a) :: spnmi => psb_lz_base_csnmi + procedure, pass(a) :: spnm1 => psb_lz_base_csnm1 + procedure, pass(a) :: rowsum => psb_lz_base_rowsum + procedure, pass(a) :: arwsum => psb_lz_base_arwsum + procedure, pass(a) :: colsum => psb_lz_base_colsum + procedure, pass(a) :: aclsum => psb_lz_base_aclsum + ! + ! Convert internal indices + ! + procedure, pass(a) :: cp_to_icoo => psb_lz_base_cp_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_lz_base_cp_from_icoo + procedure, pass(a) :: cp_to_ifmt => psb_lz_base_cp_to_ifmt + procedure, pass(a) :: cp_from_ifmt => psb_lz_base_cp_from_ifmt + procedure, pass(a) :: mv_to_icoo => psb_lz_base_mv_to_icoo + procedure, pass(a) :: mv_from_icoo => psb_lz_base_mv_from_icoo + procedure, pass(a) :: mv_to_ifmt => psb_lz_base_mv_to_ifmt + procedure, pass(a) :: mv_from_ifmt => psb_lz_base_mv_from_ifmt + + ! + ! Transpose methods: defined here but not implemented. + ! + procedure, pass(a) :: transp_1mat => psb_lz_base_transp_1mat + procedure, pass(a) :: transp_2mat => psb_lz_base_transp_2mat + procedure, pass(a) :: transc_1mat => psb_lz_base_transc_1mat + procedure, pass(a) :: transc_2mat => psb_lz_base_transc_2mat + + end type psb_lz_base_sparse_mat + + private :: lz_base_mat_sync, lz_base_mat_is_host, lz_base_mat_is_dev, & + & lz_base_mat_is_sync, lz_base_mat_set_host, lz_base_mat_set_dev,& + & lz_base_mat_set_sync + + !> \namespace psb_base_mod \class psb_lz_coo_sparse_mat + !! \extends psb_lz_base_mat_mod::psb_lz_base_sparse_mat + !! + !! psb_lz_coo_sparse_mat type and the related methods. This is the + !! reference type for all the format transitions, copies and mv unless + !! methods are implemented that allow the direct transition from one + !! format to another. It is defined here since all other classes must + !! refer to it per the MEDIATOR design pattern. + !! + type, extends(psb_lz_base_sparse_mat) :: psb_lz_coo_sparse_mat + !> Number of nonzeros. + integer(psb_lpk_) :: nnz + !> Row indices. + integer(psb_lpk_), allocatable :: ia(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + complex(psb_dpk_), allocatable :: val(:) + + integer, private :: sort_status=psb_unsorted_ + + contains + ! + ! Data management methods. + ! + procedure, pass(a) :: get_size => lz_coo_get_size + procedure, pass(a) :: get_nzeros => lz_coo_get_nzeros + procedure, nopass :: get_fmt => lz_coo_get_fmt + procedure, pass(a) :: sizeof => lz_coo_sizeof + procedure, pass(a) :: reallocate_nz => psb_lz_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_lz_coo_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_lz_cp_coo_to_coo + procedure, pass(a) :: cp_from_coo => psb_lz_cp_coo_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lz_cp_coo_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lz_cp_coo_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lz_mv_coo_to_coo + procedure, pass(a) :: mv_from_coo => psb_lz_mv_coo_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lz_mv_coo_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lz_mv_coo_from_fmt + procedure, pass(a) :: cp_to_icoo => psb_lz_cp_coo_to_icoo + procedure, pass(a) :: cp_from_icoo => psb_lz_cp_coo_from_icoo + + procedure, pass(a) :: csput_a => psb_lz_coo_csput_a + procedure, pass(a) :: get_diag => psb_lz_coo_get_diag + procedure, pass(a) :: csgetrow => psb_lz_coo_csgetrow + procedure, pass(a) :: csgetptn => psb_lz_coo_csgetptn + procedure, pass(a) :: reinit => psb_lz_coo_reinit + procedure, pass(a) :: get_nz_row => psb_lz_coo_get_nz_row + procedure, pass(a) :: fix => psb_lz_fix_coo + procedure, pass(a) :: trim => psb_lz_coo_trim + procedure, pass(a) :: clean_zeros => psb_lz_coo_clean_zeros + procedure, pass(a) :: print => psb_lz_coo_print + procedure, pass(a) :: free => lz_coo_free + procedure, pass(a) :: mold => psb_lz_coo_mold + procedure, pass(a) :: is_sorted => lz_coo_is_sorted + procedure, pass(a) :: is_by_rows => lz_coo_is_by_rows + procedure, pass(a) :: is_by_cols => lz_coo_is_by_cols + procedure, pass(a) :: set_by_rows => lz_coo_set_by_rows + procedure, pass(a) :: set_by_cols => lz_coo_set_by_cols + procedure, pass(a) :: set_sort_status => lz_coo_set_sort_status + procedure, pass(a) :: get_sort_status => lz_coo_get_sort_status + + + ! Computational methods: defined here but not implemented. + ! + procedure, pass(a) :: scals => psb_lz_coo_scals + procedure, pass(a) :: scalv => psb_lz_coo_scal + procedure, pass(a) :: maxval => psb_lz_coo_maxval + procedure, pass(a) :: spnmi => psb_lz_coo_csnmi + procedure, pass(a) :: spnm1 => psb_lz_coo_csnm1 + procedure, pass(a) :: rowsum => psb_lz_coo_rowsum + procedure, pass(a) :: arwsum => psb_lz_coo_arwsum + procedure, pass(a) :: colsum => psb_lz_coo_colsum + procedure, pass(a) :: aclsum => psb_lz_coo_aclsum + + ! + ! This is COO specific + ! + procedure, pass(a) :: set_nzeros => lz_coo_set_nzeros + + ! + ! Transpose methods. These are the base of all + ! indirection in transpose, together with conversions + ! they are sufficient for all cases. + ! + procedure, pass(a) :: transp_1mat => lz_coo_transp_1mat + procedure, pass(a) :: transc_1mat => lz_coo_transc_1mat + + + end type psb_lz_coo_sparse_mat + + private :: lz_coo_get_nzeros, lz_coo_set_nzeros, & + & lz_coo_get_fmt, lz_coo_free, lz_coo_sizeof, & + & lz_coo_transp_1mat, lz_coo_transc_1mat + ! == ================= ! @@ -257,7 +456,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax @@ -268,8 +467,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_, psb_z_base_vect_type,& - & psb_i_base_vect_type + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_vect_type), intent(inout) :: val class(psb_i_base_vect_type), intent(inout) :: ia, ja @@ -314,7 +512,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -324,7 +522,7 @@ module psb_z_base_mat_mod logical, intent(in), optional :: append integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale, chksz + logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_z_base_csgetrow end interface @@ -353,7 +551,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& & jmin,jmax,iren,append,rscale,cscale,chksz) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(in) :: imin,imax @@ -391,7 +589,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_base_csclip(a,b,info,& & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: b integer(psb_ipk_),intent(out) :: info @@ -432,7 +630,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_base_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -476,7 +674,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_base_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -499,7 +697,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_get_diag(a,d,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -518,7 +716,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_mold(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_long_int_k_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -540,7 +738,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_clone(a,b, info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_long_int_k_ + import implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), allocatable, intent(inout) :: b @@ -559,7 +757,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_make_nonunit(a) - import :: psb_z_base_sparse_mat + import implicit none class(psb_z_base_sparse_mat), intent(inout) :: a end subroutine psb_z_base_make_nonunit @@ -576,7 +774,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_cp_to_coo(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -593,7 +791,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_cp_from_coo(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -611,7 +809,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_cp_to_fmt(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -629,7 +827,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_cp_from_fmt(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -646,7 +844,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_mv_to_coo(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -663,7 +861,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_mv_from_coo(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -681,7 +879,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_mv_to_fmt(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -699,12 +897,153 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_mv_from_fmt(a,b,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_mv_from_fmt end interface + ! + !> Function cp_to_coo: + !! \memberof psb_z_base_sparse_mat + !! \brief Copy and convert to psb_z_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_z_base_cp_to_lcoo(a,b,info) + import + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_cp_to_lcoo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_z_base_sparse_mat + !! \brief Copy and convert from psb_z_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_z_base_cp_from_lcoo(a,b,info) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_cp_from_lcoo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_z_base_sparse_mat + !! \brief Copy and convert to a class(psb_z_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_z_base_cp_to_lfmt(a,b,info) + import + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_cp_to_lfmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_z_base_sparse_mat + !! \brief Copy and convert from a class(psb_z_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_z_base_cp_from_lfmt(a,b,info) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_cp_from_lfmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_z_base_sparse_mat + !! \brief Convert to psb_z_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_z_base_mv_to_lcoo(a,b,info) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_mv_to_lcoo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_z_base_sparse_mat + !! \brief Convert from psb_z_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_z_base_mv_from_lcoo(a,b,info) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_mv_from_lcoo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_z_base_sparse_mat + !! \brief Convert to a class(psb_z_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_z_base_mv_to_lfmt(a,b,info) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_mv_to_lfmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_z_base_sparse_mat + !! \brief Convert from a class(psb_z_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_z_base_mv_from_lfmt(a,b,info) + import + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_mv_from_lfmt + end interface + + ! !> !! \memberof psb_z_base_sparse_mat @@ -712,7 +1051,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_clean_zeros(a, info) - import :: psb_ipk_, psb_z_base_sparse_mat + import class(psb_z_base_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_clean_zeros @@ -728,7 +1067,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_transp_2mat(a,b) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_z_base_transp_2mat @@ -744,7 +1083,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_transc_2mat(a,b) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(out) :: b end subroutine psb_z_base_transc_2mat @@ -759,7 +1098,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_transp_1mat(a) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a end subroutine psb_z_base_transp_1mat end interface @@ -773,7 +1112,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_transc_1mat(a) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a end subroutine psb_z_base_transc_1mat end interface @@ -798,7 +1137,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -826,7 +1165,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -861,7 +1200,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_vect_mv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_, psb_z_base_vect_type + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x @@ -893,7 +1232,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -928,7 +1267,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -963,7 +1302,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_, psb_z_base_vect_type + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x, y @@ -995,7 +1334,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1028,7 +1367,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1062,7 +1401,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_,psb_z_base_vect_type + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta class(psb_z_base_vect_type), intent(inout) :: x,y @@ -1082,7 +1421,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_scals(d,a,info) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -1100,7 +1439,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_scal(d,a,info,side) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1116,7 +1455,7 @@ module psb_z_base_mat_mod ! interface function psb_z_base_maxval(a) result(res) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_base_maxval @@ -1131,7 +1470,7 @@ module psb_z_base_mat_mod ! interface function psb_z_base_csnmi(a) result(res) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_base_csnmi @@ -1146,7 +1485,7 @@ module psb_z_base_mat_mod ! interface function psb_z_base_csnm1(a) result(res) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_base_csnm1 @@ -1162,7 +1501,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_rowsum(d,a) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_base_rowsum @@ -1176,7 +1515,7 @@ module psb_z_base_mat_mod !! interface subroutine psb_z_base_arwsum(d,a) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_base_arwsum @@ -1192,7 +1531,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_base_colsum(d,a) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_base_colsum @@ -1206,7 +1545,7 @@ module psb_z_base_mat_mod !! interface subroutine psb_z_base_aclsum(d,a) - import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_ + import class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_base_aclsum @@ -1226,7 +1565,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_coo_reallocate_nz(nz,a) - import :: psb_ipk_, psb_z_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_z_coo_sparse_mat), intent(inout) :: a end subroutine psb_z_coo_reallocate_nz @@ -1239,7 +1578,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_coo_reinit(a,clear) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_z_coo_reinit @@ -1251,7 +1590,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_coo_trim(a) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a end subroutine psb_z_coo_trim end interface @@ -1262,7 +1601,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_coo_clean_zeros(a,info) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_clean_zeros @@ -1275,7 +1614,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_z_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -1287,7 +1626,7 @@ module psb_z_base_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_z_coo_mold(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ + import class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -1309,7 +1648,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_z_coo_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -1330,7 +1669,7 @@ module psb_z_base_mat_mod ! interface function psb_z_coo_get_nz_row(idx,a) result(res) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: idx integer(psb_ipk_) :: res @@ -1354,11 +1693,12 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) - import :: psb_ipk_, psb_dpk_ + import integer(psb_ipk_), intent(in) :: nr,nc,nzin,dupl integer(psb_ipk_), intent(inout) :: ia(:), ja(:) complex(psb_dpk_), intent(inout) :: val(:) - integer(psb_ipk_), intent(out) :: nzout, info + integer(psb_ipk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir end subroutine psb_z_fix_coo_inner end interface @@ -1373,7 +1713,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_fix_coo(a,info,idir) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: idir @@ -1385,7 +1725,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_to_coo interface subroutine psb_z_cp_coo_to_coo(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1397,12 +1737,35 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo interface subroutine psb_z_cp_coo_from_coo(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info end subroutine psb_z_cp_coo_from_coo end interface + !> + !! \memberof psb_z_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_z_base_cp_to_coo + interface + subroutine psb_z_cp_coo_to_lcoo(a,b,info) + import + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_cp_coo_to_lcoo + end interface + + !> + !! \memberof psb_z_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo + interface + subroutine psb_z_cp_coo_from_lcoo(a,b,info) + import + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_cp_coo_from_lcoo + end interface !> !! \memberof psb_z_coo_sparse_mat @@ -1410,7 +1773,7 @@ module psb_z_base_mat_mod !! interface subroutine psb_z_cp_coo_to_fmt(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1423,7 +1786,7 @@ module psb_z_base_mat_mod !! interface subroutine psb_z_cp_coo_from_fmt(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -1435,7 +1798,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_to_coo interface subroutine psb_z_mv_coo_to_coo(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1447,7 +1810,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_from_coo interface subroutine psb_z_mv_coo_from_coo(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1459,7 +1822,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_to_fmt interface subroutine psb_z_mv_coo_to_fmt(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1471,7 +1834,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_from_fmt interface subroutine psb_z_mv_coo_from_fmt(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_coo_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -1480,7 +1843,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_coo_cp_from(a,b) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(inout) :: a type(psb_z_coo_sparse_mat), intent(in) :: b end subroutine psb_z_coo_cp_from @@ -1488,7 +1851,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_coo_mv_from(a,b) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(inout) :: a type(psb_z_coo_sparse_mat), intent(inout) :: b end subroutine psb_z_coo_mv_from @@ -1513,7 +1876,7 @@ module psb_z_base_mat_mod ! interface subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -1529,7 +1892,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1548,7 +1911,7 @@ module psb_z_base_mat_mod interface subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -1567,7 +1930,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cssv interface subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1580,7 +1943,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cssm interface subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1594,7 +1957,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csmv interface subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -1608,7 +1971,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csmm interface subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -1623,7 +1986,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_maxval interface function psb_z_coo_maxval(a) result(res) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_coo_maxval @@ -1634,7 +1997,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csnmi interface function psb_z_coo_csnmi(a) result(res) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_coo_csnmi @@ -1645,7 +2008,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csnm1 interface function psb_z_coo_csnm1(a) result(res) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_coo_csnm1 @@ -1656,7 +2019,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_rowsum interface subroutine psb_z_coo_rowsum(d,a) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_coo_rowsum @@ -1666,7 +2029,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_arwsum interface subroutine psb_z_coo_arwsum(d,a) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_coo_arwsum @@ -1677,7 +2040,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_colsum interface subroutine psb_z_coo_colsum(d,a) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_coo_colsum @@ -1688,7 +2051,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_aclsum interface subroutine psb_z_coo_aclsum(d,a) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_coo_aclsum @@ -1699,7 +2062,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_get_diag interface subroutine psb_z_coo_get_diag(a,d,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1711,7 +2074,7 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_scal interface subroutine psb_z_coo_scal(d,a,info,side) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -1724,13 +2087,1351 @@ module psb_z_base_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_scals interface subroutine psb_z_coo_scals(d,a,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_coo_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_scals end interface + ! == ================= + ! + ! BASE interfaces + ! + ! == ================= + + !> Function csput: + !! \memberof psb_lz_base_sparse_mat + !! \brief Insert coefficients. + !! + !! + !! Given a list of NZ triples + !! (IA(i),JA(i),VAL(i)) + !! record a new coefficient in A such that + !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ). + !! + !! The internal components IA,JA,VAL are reallocated as necessary. + !! Constraints: + !! - If the matrix A is in the BUILD state, then the method will + !! only work for COO matrices, all other format will throw an error. + !! In this case coefficients are queued inside A for further processing. + !! - If the matrix A is in the UPDATE state, then it can be in any format; + !! the update operation will perform either + !! A(IA(1:nz),JA(1:nz)) = VAL(1:NZ) + !! or + !! A(IA(1:nz),JA(1:nz)) = A(IA(1:nz),JA(1:nz))+VAL(1:NZ) + !! according to the value of DUPLICATE. + !! - Coefficients with (IA(I),JA(I)) outside the ranges specified by + !! IMIN:IMAX,JMIN:JMAX will be ignored. + !! + !! \param nz number of triples in input + !! \param ia(:) the input row indices + !! \param ja(:) the input col indices + !! \param val(:) the input coefficients + !! \param imin minimum row index + !! \param imax maximum row index + !! \param jmin minimum col index + !! \param jmax maximum col index + !! \param info return code + !! \param gtl(:) [none] an array to renumber indices (iren(ia(:)),iren(ja(:)) + !! + ! + interface + subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_base_csput_a + end interface + + interface + subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin, imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_base_csput_v + end interface + + ! + ! + !> Function csgetrow: + !! \memberof psb_lz_base_sparse_mat + !! \brief Get a (subset of) row(s) + !! + !! getrow is the basic method by which the other (getblk, clip) can + !! be implemented. + !! + !! Returns the set + !! NZ, IA(1:nz), JA(1:nz), VAL(1:NZ) + !! each identifying the position of a nonzero in A + !! between row indices IMIN:IMAX; + !! IA,JA are reallocated as necessary. + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param nz the number of output coefficients + !! \param ia(:) the output row indices + !! \param ja(:) the output col indices + !! \param val(:) the output coefficients + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_lz_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_base_csgetrow + end interface + + ! + !> Function csgetblk: + !! \memberof psb_lz_base_sparse_mat + !! \brief Get a (subset of) row(s) + !! + !! getblk is very similar to getrow, except that the output + !! is packaged in a psb_lz_coo_sparse_mat object + !! + !! \param imin the minimum row index we are interested in + !! \param imax the minimum row index we are interested in + !! \param b the output (sub)matrix + !! \param info return code + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_lz_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_base_csgetblk + end interface + + ! + ! + !> Function csclip: + !! \memberof psb_lz_base_sparse_mat + !! \brief Get a submatrix. + !! + !! csclip is practically identical to getblk. + !! One of them has to go away..... + !! + !! \param b the output submatrix + !! \param info return code + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! + ! + interface + subroutine psb_lz_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_base_csclip + end interface + ! + !> Function tril: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_lz_base_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_lz_base_tril + end interface + + ! + !> Function triu: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_lz_base_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_lz_base_triu + end interface + + + ! + !> Function get_diag: + !! \memberof psb_lz_base_sparse_mat + !! \brief Extract the diagonal of A. + !! + !! D(i) = A(i:i), i=1:min(nrows,ncols) + !! + !! \param d(:) The output diagonal + !! \param info return code. + ! + interface + subroutine psb_lz_base_get_diag(a,d,info) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_get_diag + end interface + + ! + !> Function mold: + !! \memberof psb_lz_base_sparse_mat + !! \brief Allocate a class(psb_lz_base_sparse_mat) with the + !! same dynamic type as the input. + !! This is equivalent to allocate( mold= ) and is provided + !! for those compilers not yet supporting mold. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mold(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mold + end interface + + ! + ! + !> Function clone: + !! \memberof psb_lz_base_sparse_mat + !! \brief Allocate and clone a class(psb_lz_base_sparse_mat) with the + !! same dynamic type as the input. + !! This is equivalent to allocate( source= ) except that + !! it should guarantee a deep copy wherever needed. + !! Should also be equivalent to calling mold and then copy, + !! but it can also be implemented by default using cp_to_fmt. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_clone(a,b, info) + import + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_clone + end interface + + + ! + ! + !> Function make_nonunit: + !! \memberof psb_lz_base_make_nonunit + !! \brief Given a matrix for which is_unit() is true, explicitly + !! store the unit diagonal and set is_unit() to false. + !! This is needed e.g. when scaling + ! + interface + subroutine psb_lz_base_make_nonunit(a) + import + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + end subroutine psb_lz_base_make_nonunit + end interface + + + ! + !> Function cp_to_coo: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy and convert to psb_lz_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_cp_to_coo(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_cp_to_coo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy and convert from psb_lz_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_lz_base_cp_from_coo(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_cp_from_coo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy and convert to a class(psb_lz_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_cp_to_fmt(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_cp_to_fmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy and convert from a class(psb_lz_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_cp_from_fmt(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_cp_from_fmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_lz_base_sparse_mat + !! \brief Convert to psb_lz_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mv_to_coo(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mv_to_coo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_lz_base_sparse_mat + !! \brief Convert from psb_lz_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mv_from_coo(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mv_from_coo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_lz_base_sparse_mat + !! \brief Convert to a class(psb_lz_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mv_to_fmt(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mv_to_fmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_lz_base_sparse_mat + !! \brief Convert from a class(psb_lz_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mv_from_fmt(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mv_from_fmt + end interface + + + ! + !> Function cp_to_coo: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy and convert to psb_lz_coo_sparse_mat + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_cp_to_icoo(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_cp_to_icoo + end interface + + ! + !> Function cp_from_coo: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy and convert from psb_lz_coo_sparse_mat + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_lz_base_cp_from_icoo(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_cp_from_icoo + end interface + + ! + !> Function cp_to_fmt: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy and convert to a class(psb_lz_base_sparse_mat) + !! Invoked from the source object. Can be implemented by + !! simply invoking a%cp_to_coo(tmp) and then b%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_cp_to_ifmt(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_cp_to_ifmt + end interface + + ! + !> Function cp_from_fmt: + !! \memberof psb_lz_base_sparse_mat + !! \brief Copy and convert from a class(psb_lz_base_sparse_mat) + !! Invoked from the target object. Can be implemented by + !! simply invoking b%cp_to_coo(tmp) and then a%cp_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_cp_from_ifmt(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_cp_from_ifmt + end interface + + ! + !> Function mv_to_coo: + !! \memberof psb_lz_base_sparse_mat + !! \brief Convert to psb_lz_coo_sparse_mat, freeing the source. + !! Invoked from the source object. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mv_to_icoo(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mv_to_icoo + end interface + + ! + !> Function mv_from_coo: + !! \memberof psb_lz_base_sparse_mat + !! \brief Convert from psb_lz_coo_sparse_mat, freeing the source. + !! Invoked from the target object. + !! \param b The input variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mv_from_icoo(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mv_from_icoo + end interface + + ! + !> Function mv_to_fmt: + !! \memberof psb_lz_base_sparse_mat + !! \brief Convert to a class(psb_lz_base_sparse_mat), freeing the source. + !! Invoked from the source object. Can be implemented by + !! simply invoking a%mv_to_coo(tmp) and then b%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mv_to_ifmt(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mv_to_ifmt + end interface + + ! + !> Function mv_from_fmt: + !! \memberof psb_lz_base_sparse_mat + !! \brief Convert from a class(psb_lz_base_sparse_mat), freeing the source. + !! Invoked from the target object. Can be implemented by + !! simply invoking b%mv_to_coo(tmp) and then a%mv_from_coo(tmp). + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_lz_base_mv_from_ifmt(a,b,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_mv_from_ifmt + end interface + + + + ! + !> + !! \memberof psb_lz_base_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_clean_zeros + ! + interface + subroutine psb_lz_base_clean_zeros(a, info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_clean_zeros + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_maxval + interface + function psb_lz_coo_maxval(a) result(res) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_coo_maxval + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_csnmi + interface + function psb_lz_coo_csnmi(a) result(res) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_coo_csnmi + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_csnm1 + interface + function psb_lz_coo_csnm1(a) result(res) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_coo_csnm1 + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_rowsum + interface + subroutine psb_lz_coo_rowsum(d,a) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_coo_rowsum + end interface + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_arwsum + interface + subroutine psb_lz_coo_arwsum(d,a) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_coo_arwsum + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_colsum + interface + subroutine psb_lz_coo_colsum(d,a) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_coo_colsum + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_aclsum + interface + subroutine psb_lz_coo_aclsum(d,a) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_coo_aclsum + end interface + + ! + !> Function base_scals: + !! \memberof psb_lz_base_sparse_mat + !! \brief Scale a matrix by a single scalar value + !! + !! \param d Scaling factor + !! \param info return code + ! + interface + subroutine psb_lz_base_scals(d,a,info) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_base_scals + end interface + + ! + !> Function base_scal: + !! \memberof psb_lz_base_sparse_mat + !! \brief Scale a matrix by a vector + !! + !! \param d(:) Scaling vector + !! \param info return code + !! \param side [L] Scale on the Left (rows) or on the Right (columns) + ! + interface + subroutine psb_lz_base_scal(d,a,info,side) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lz_base_scal + end interface + + ! + !> Function base_maxval: + !! \memberof psb_lz_base_sparse_mat + !! \brief Maximum absolute value of all coefficients; + !! + ! + interface + function psb_lz_base_maxval(a) result(res) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_base_maxval + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_lz_base_sparse_mat + !! \brief Operator infinity norm + !! + ! + interface + function psb_lz_base_csnmi(a) result(res) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_base_csnmi + end interface + + ! + ! + !> Function base_csnmi: + !! \memberof psb_lz_base_sparse_mat + !! \brief Operator 1-norm + !! + ! + interface + function psb_lz_base_csnm1(a) result(res) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_base_csnm1 + end interface + + ! + ! + !> Function base_rowsum: + !! \memberof psb_lz_base_sparse_mat + !! \brief Sum along the rows + !! \param d(:) The output row sums + !! + ! + interface + subroutine psb_lz_base_rowsum(d,a) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_base_rowsum + end interface + + ! + !> Function base_arwsum: + !! \memberof psb_lz_base_sparse_mat + !! \brief Absolute value sum along the rows + !! \param d(:) The output row sums + !! + interface + subroutine psb_lz_base_arwsum(d,a) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_base_arwsum + end interface + + ! + ! + !> Function base_colsum: + !! \memberof psb_lz_base_sparse_mat + !! \brief Sum along the columns + !! \param d(:) The output col sums + !! + ! + interface + subroutine psb_lz_base_colsum(d,a) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_base_colsum + end interface + + ! + !> Function base_aclsum: + !! \memberof psb_lz_base_sparse_mat + !! \brief Absolute value sum along the columns + !! \param d(:) The output col sums + !! + interface + subroutine psb_lz_base_aclsum(d,a) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_base_aclsum + end interface + + + ! + !> Function transp: + !! \memberof psb_lz_base_sparse_mat + !! \brief Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! Copyout version + !! \param b The output variable + ! + interface + subroutine psb_lz_base_transp_2mat(a,b) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + end subroutine psb_lz_base_transp_2mat + end interface + + ! + !> Function transc: + !! \memberof psb_lz_base_sparse_mat + !! \brief Conjugate Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! Copyout version. + !! \param b The output variable + ! + interface + subroutine psb_lz_base_transc_2mat(a,b) + import + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + end subroutine psb_lz_base_transc_2mat + end interface + + ! + !> Function transp: + !! \memberof psb_lz_base_sparse_mat + !! \brief Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! In-place version. + ! + interface + subroutine psb_lz_base_transp_1mat(a) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + end subroutine psb_lz_base_transp_1mat + end interface + + ! + !> Function transc: + !! \memberof psb_lz_base_sparse_mat + !! \brief Conjugate Transpose. Can always be implemented by staging through a COO + !! temporary for which transpose is very easy. + !! In-place version. + ! + interface + subroutine psb_lz_base_transc_1mat(a) + import + class(psb_lz_base_sparse_mat), intent(inout) :: a + end subroutine psb_lz_base_transc_1mat + end interface + + ! == =============== + ! + ! COO interfaces + ! + ! == =============== + + ! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reallocate_nz + ! + interface + subroutine psb_lz_coo_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_coo_sparse_mat), intent(inout) :: a + end subroutine psb_lz_coo_reallocate_nz + end interface + + ! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_reinit + ! + interface + subroutine psb_lz_coo_reinit(a,clear) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lz_coo_reinit + end interface + ! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_trim + ! + interface + subroutine psb_lz_coo_trim(a) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + end subroutine psb_lz_coo_trim + end interface + ! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_clean_zeros + ! + interface + subroutine psb_lz_coo_clean_zeros(a,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_coo_clean_zeros + end interface + + ! + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_allocate_mnnz + ! + interface + subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lz_coo_allocate_mnnz + end interface + + + !> \memberof psb_lz_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_lz_coo_mold(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_coo_mold + end interface + + + ! + !> Function print. + !! \memberof psb_lz_coo_sparse_mat + !! \brief Print the matrix to file in MatrixMarket format + !! + !! \param iout The unit to write to + !! \param iv [none] Renumbering for both rows and columns + !! \param head [none] Descriptive header for the file + !! \param ivr [none] Row renumbering + !! \param ivc [none] Col renumbering + !! + ! + interface + subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_coo_print + end interface + + + + ! + !> Function get_nz_row. + !! \memberof psb_lz_coo_sparse_mat + !! \brief How many nonzeros in a row? + !! + !! \param idx The row to search. + !! + ! + interface + function psb_lz_coo_get_nz_row(idx,a) result(res) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + end function psb_lz_coo_get_nz_row + end interface + + + ! + !> Funtion: fix_coo_inner + !! \brief Make sure the entries are sorted and duplicates are handled. + !! Used internally by fix_coo + !! \param nzin Number of entries on input to be handled + !! \param dupl What to do with duplicated entries. + !! \param ia(:) Row indices + !! \param ja(:) Col indices + !! \param val(:) Coefficients + !! \param nzout Number of entries after sorting/duplicate handling + !! \param info return code + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! + ! + interface + subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + import + integer(psb_lpk_), intent(in) :: nr,nc,nzin + integer(psb_ipk_), intent(in) :: dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + end subroutine psb_lz_fix_coo_inner + end interface + + ! + !> Function fix_coo + !! \memberof psb_lz_coo_sparse_mat + !! \brief Make sure the entries are sorted and duplicates are handled. + !! \param info return code + !! \param idir [psb_row_major_] Sort in row major order or col major order + !! + ! + interface + subroutine psb_lz_fix_coo(a,info,idir) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + end subroutine psb_lz_fix_coo + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo + interface + subroutine psb_lz_cp_coo_to_coo(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_coo_to_coo + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo + interface + subroutine psb_lz_cp_coo_from_coo(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_coo_from_coo + end interface + + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo + interface + subroutine psb_lz_cp_coo_to_icoo(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_coo_to_icoo + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo + interface + subroutine psb_lz_cp_coo_from_icoo(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_coo_from_icoo + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo + !! + interface + subroutine psb_lz_cp_coo_to_fmt(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_coo_to_fmt + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_fmt + !! + interface + subroutine psb_lz_cp_coo_from_fmt(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_coo_from_fmt + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_coo + interface + subroutine psb_lz_mv_coo_to_coo(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_coo_to_coo + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_coo + interface + subroutine psb_lz_mv_coo_from_coo(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_coo_from_coo + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_fmt + interface + subroutine psb_lz_mv_coo_to_fmt(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_coo_to_fmt + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_fmt + interface + subroutine psb_lz_mv_coo_from_fmt(a,b,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_coo_from_fmt + end interface + + interface + subroutine psb_lz_coo_cp_from(a,b) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + type(psb_lz_coo_sparse_mat), intent(in) :: b + end subroutine psb_lz_coo_cp_from + end interface + + interface + subroutine psb_lz_coo_mv_from(a,b) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + type(psb_lz_coo_sparse_mat), intent(inout) :: b + end subroutine psb_lz_coo_mv_from + end interface + + + !> Function csput + !! \memberof psb_lz_coo_sparse_mat + !! \brief Add coefficients into the matrix. + !! + !! \param nz Number of entries to be added + !! \param ia(:) Row indices + !! \param ja(:) Col indices + !! \param val(:) Values + !! \param imin Minimum row index to accept + !! \param imax Maximum row index to accept + !! \param jmin Minimum col index to accept + !! \param jmax Maximum col index to accept + !! \param info return code + !! \param gtl [none] Renumbering for rows/columns + !! + ! + interface + subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_coo_csput_a + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_coo_csgetptn + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csgetrow + interface + subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_coo_csgetrow + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_get_diag + interface + subroutine psb_lz_coo_get_diag(a,d,info) + import + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_coo_get_diag + end interface + + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scal + interface + subroutine psb_lz_coo_scal(d,a,info,side) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lz_coo_scal + end interface + + !> + !! \memberof psb_lz_coo_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scals + interface + subroutine psb_lz_coo_scals(d,a,info) + import + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_coo_scals + end interface contains @@ -1752,11 +3453,11 @@ contains function z_coo_sizeof(a) result(res) implicit none class(psb_z_coo_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + 1 + integer(psb_epk_) :: res + res = 3*psb_sizeof_ip res = res + (2*psb_sizeof_dp) * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%ia) - res = res + psb_sizeof_int * psb_size(a%ja) + res = res + psb_sizeof_ip * psb_size(a%ia) + res = res + psb_sizeof_ip * psb_size(a%ja) end function z_coo_sizeof @@ -1902,9 +3603,9 @@ contains if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) - call a%set_nzeros(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) + call a%set_nzeros(0_psb_ipk_) call a%set_sort_status(psb_unsorted_) return @@ -1958,6 +3659,230 @@ contains end subroutine z_coo_transc_1mat + + ! == ================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == ================================== + + + + function lz_coo_sizeof(a) result(res) + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 3*psb_sizeof_lp + res = res + (2*psb_sizeof_dp) * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%ia) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function lz_coo_sizeof + + + function lz_coo_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'COO' + end function lz_coo_get_fmt + + + function lz_coo_get_size(a) result(res) + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = -1 + + if (allocated(a%ia)) res = size(a%ia) + if (allocated(a%ja)) then + if (res >= 0) then + res = min(res,size(a%ja)) + else + res = size(a%ja) + end if + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + end function lz_coo_get_size + + + function lz_coo_get_nzeros(a) result(res) + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%nnz + end function lz_coo_get_nzeros + + function lz_coo_is_by_rows(a) result(res) + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_row_major_) + end function lz_coo_is_by_rows + + function lz_coo_is_by_cols(a) result(res) + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_col_major_) + end function lz_coo_is_by_cols + + function lz_coo_is_sorted(a) result(res) + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + logical :: res + res = (a%sort_status == psb_row_major_) & + & .or.(a%sort_status == psb_col_major_) + end function lz_coo_is_sorted + + + + ! == ================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == ================================== + + subroutine lz_coo_set_nzeros(nz,a) + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_coo_sparse_mat), intent(inout) :: a + + a%nnz = nz + + end subroutine lz_coo_set_nzeros + + function lz_coo_get_sort_status(a) result(res) + implicit none + integer(psb_ipk_) :: res + class(psb_lz_coo_sparse_mat), intent(in) :: a + + res = a%sort_status + end function lz_coo_get_sort_status + + subroutine lz_coo_set_sort_status(ist,a) + implicit none + integer(psb_ipk_), intent(in) :: ist + class(psb_lz_coo_sparse_mat), intent(inout) :: a + + a%sort_status = ist + call a%set_sorted((a%sort_status == psb_row_major_) & + & .or.(a%sort_status == psb_col_major_)) + end subroutine lz_coo_set_sort_status + + + subroutine lz_coo_set_by_rows(a) + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + + a%sort_status = psb_row_major_ + call a%set_sorted() + end subroutine lz_coo_set_by_rows + + + subroutine lz_coo_set_by_cols(a) + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + + a%sort_status = psb_col_major_ + call a%set_sorted() + end subroutine lz_coo_set_by_cols + + ! == ================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == ================================== + + subroutine lz_coo_free(a) + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + call a%set_nzeros(0_psb_lpk_) + call a%set_sort_status(psb_unsorted_) + + return + + end subroutine lz_coo_free + + + + ! == ================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + ! == ================================== + subroutine lz_coo_transp_1mat(a) + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + + integer(psb_lpk_), allocatable :: itemp(:) + integer(psb_ipk_) :: info + + call a%psb_lz_base_sparse_mat%psb_lbase_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%set_sorted(.false.) + call a%set_sort_status(psb_unsorted_) + + return + + end subroutine lz_coo_transp_1mat + + subroutine lz_coo_transc_1mat(a) + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + + call a%transp() + ! This will morph into conjg() for C and Z + ! and into a no-op for S and D, so a conditional + ! on a constant ought to take it out completely. + if (psb_lz_is_complex_) a%val(:) = conjg(a%val(:)) + + end subroutine lz_coo_transc_1mat + end module psb_z_base_mat_mod diff --git a/base/modules/serial/psb_z_base_vect_mod.f90 b/base/modules/serial/psb_z_base_vect_mod.f90 index 479e7cd9a..6dd242cc3 100644 --- a/base/modules/serial/psb_z_base_vect_mod.f90 +++ b/base/modules/serial/psb_z_base_vect_mod.f90 @@ -48,6 +48,7 @@ module psb_z_base_vect_mod use psb_error_mod use psb_realloc_mod use psb_i_base_vect_mod + use psb_l_base_vect_mod !> \namespace psb_base_mod \class psb_z_base_vect_type !! The psb_z_base_vect_type @@ -63,14 +64,15 @@ module psb_z_base_vect_mod !> Values. complex(psb_dpk_), allocatable :: v(:) complex(psb_dpk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators ! procedure, pass(x) :: bld_x => z_base_bld_x - procedure, pass(x) :: bld_n => z_base_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => z_base_bld_mn + procedure, pass(x) :: bld_en => z_base_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: all => z_base_all procedure, pass(x) :: mold => z_base_mold ! @@ -82,7 +84,9 @@ module psb_z_base_vect_mod procedure, pass(x) :: ins_v => z_base_ins_v generic, public :: ins => ins_a, ins_v procedure, pass(x) :: zero => z_base_zero - procedure, pass(x) :: asb => z_base_asb + procedure, pass(x) :: asb_m => z_base_asb_m + procedure, pass(x) :: asb_e => z_base_asb_e + generic, public :: asb => asb_m, asb_e procedure, pass(x) :: free => z_base_free ! ! Sync: centerpiece of handling of external storage. @@ -240,22 +244,39 @@ contains ! Create with size, but no initialization ! - !> Function bld_n: + !> Function bld_mn: !! \memberof psb_z_base_vect_type !! \brief Build method with size (uninitialized data) !! \param n size to be allocated. !! - subroutine z_base_bld_n(x,n) + subroutine z_base_bld_mn(x,n) use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_) :: info call psb_realloc(n,x%v,info) call x%asb(n,info) - end subroutine z_base_bld_n + end subroutine z_base_bld_mn + + !> Function bld_en: + !! \memberof psb_z_base_vect_type + !! \brief Build method with size (uninitialized data) + !! \param n size to be allocated. + !! + subroutine z_base_bld_en(x,n) + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_) :: info + + call psb_realloc(n,x%v,info) + call x%asb(n,info) + + end subroutine z_base_bld_en !> Function base_all: !! \memberof psb_z_base_vect_type @@ -437,11 +458,11 @@ contains !! ! - subroutine z_base_asb(n, x, info) + subroutine z_base_asb_m(n, x, info) use psi_serial_mod use psb_realloc_mod implicit none - integer(psb_ipk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: n class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(out) :: info @@ -451,7 +472,37 @@ contains if (info /= 0) & & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') call x%sync() - end subroutine z_base_asb + end subroutine z_base_asb_m + + ! + ! Assembly. + ! For derived classes: after this the vector + ! storage is supposed to be in sync. + ! + !> Function base_asb: + !! \memberof psb_z_base_vect_type + !! \brief Assemble vector: reallocate as necessary. + !! + !! \param n final size + !! \param info return code + !! + ! + + subroutine z_base_asb_e(n, x, info) + use psi_serial_mod + use psb_realloc_mod + implicit none + integer(psb_epk_), intent(in) :: n + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (x%get_nrows() < n) & + & call psb_realloc(n,x%v,info) + if (info /= 0) & + & call psb_errpush(psb_err_alloc_dealloc_,'vect_asb') + call x%sync() + end subroutine z_base_asb_e ! !> Function base_free: @@ -662,10 +713,10 @@ contains function z_base_sizeof(x) result(res) implicit none class(psb_z_base_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * (2*psb_sizeof_dp)) * x%get_nrows() + res = (1_psb_epk_ * (2*psb_sizeof_dp)) * x%get_nrows() end function z_base_sizeof @@ -753,7 +804,6 @@ contains integer(psb_ipk_) :: info, first_, last_, nr - first_ = 1 if (present(first)) first_ = max(1,first) last_ = min(psb_size(x%v),first_+size(val)-1) @@ -1415,7 +1465,7 @@ module psb_z_base_multivect_mod !> Values. complex(psb_dpk_), allocatable :: v(:,:) complex(psb_dpk_), allocatable :: combuf(:) - integer(psb_mpik_), allocatable :: comid(:,:) + integer(psb_mpk_), allocatable :: comid(:,:) contains ! ! Constructors/allocators @@ -1933,10 +1983,10 @@ contains function z_base_mlv_sizeof(x) result(res) implicit none class(psb_z_base_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res ! Force 8-byte integers. - res = (1_psb_long_int_k_ * psb_sizeof_int) * x%get_nrows() * x%get_ncols() + res = (1_psb_epk_ * psb_sizeof_ip) * x%get_nrows() * x%get_ncols() end function z_base_mlv_sizeof diff --git a/base/modules/serial/psb_z_csc_mat_mod.f90 b/base/modules/serial/psb_z_csc_mat_mod.f90 index 4c7e050d0..19fb0b235 100644 --- a/base/modules/serial/psb_z_csc_mat_mod.f90 +++ b/base/modules/serial/psb_z_csc_mat_mod.f90 @@ -100,14 +100,69 @@ module psb_z_csc_mat_mod end type psb_z_csc_sparse_mat - private :: z_csc_get_nzeros, z_csc_free, z_csc_get_fmt, & + private :: z_csc_get_nzeros, z_csc_free, z_csc_get_fmt, & & z_csc_get_size, z_csc_sizeof, z_csc_get_nz_col + + !> \namespace psb_base_mod \class psb_z_csc_sparse_mat + !! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat + !! + !! psb_z_csc_sparse_mat type and the related methods. + !! + type, extends(psb_lz_base_sparse_mat) :: psb_lz_csc_sparse_mat + + !> Pointers to beginning of cols in IA and VAL. + integer(psb_lpk_), allocatable :: icp(:) + !> Row indices. + integer(psb_lpk_), allocatable :: ia(:) + !> Coefficient values. + complex(psb_dpk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_cols => lz_csc_is_by_cols + procedure, pass(a) :: get_size => lz_csc_get_size + procedure, pass(a) :: get_nzeros => lz_csc_get_nzeros + procedure, nopass :: get_fmt => lz_csc_get_fmt + procedure, pass(a) :: sizeof => lz_csc_sizeof + procedure, pass(a) :: scals => psb_lz_csc_scals + procedure, pass(a) :: scalv => psb_lz_csc_scal + procedure, pass(a) :: maxval => psb_lz_csc_maxval + procedure, pass(a) :: spnm1 => psb_lz_csc_csnm1 + procedure, pass(a) :: rowsum => psb_lz_csc_rowsum + procedure, pass(a) :: arwsum => psb_lz_csc_arwsum + procedure, pass(a) :: colsum => psb_lz_csc_colsum + procedure, pass(a) :: aclsum => psb_lz_csc_aclsum + procedure, pass(a) :: reallocate_nz => psb_lz_csc_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_lz_csc_allocate_mnnz + procedure, pass(a) :: cp_to_coo => psb_lz_cp_csc_to_coo + procedure, pass(a) :: cp_from_coo => psb_lz_cp_csc_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lz_cp_csc_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lz_cp_csc_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lz_mv_csc_to_coo + procedure, pass(a) :: mv_from_coo => psb_lz_mv_csc_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lz_mv_csc_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lz_mv_csc_from_fmt + procedure, pass(a) :: csput_a => psb_lz_csc_csput_a + procedure, pass(a) :: get_diag => psb_lz_csc_get_diag + procedure, pass(a) :: csgetptn => psb_lz_csc_csgetptn + procedure, pass(a) :: csgetrow => psb_lz_csc_csgetrow + procedure, pass(a) :: get_nz_col => lz_csc_get_nz_col + procedure, pass(a) :: reinit => psb_lz_csc_reinit + procedure, pass(a) :: trim => psb_lz_csc_trim + procedure, pass(a) :: print => psb_lz_csc_print + procedure, pass(a) :: free => lz_csc_free + procedure, pass(a) :: mold => psb_lz_csc_mold + + end type psb_lz_csc_sparse_mat + + private :: lz_csc_get_nzeros, lz_csc_free, lz_csc_get_fmt, & + & lz_csc_get_size, lz_csc_sizeof, lz_csc_get_nz_col + !> \memberof psb_z_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_reallocate_nz interface subroutine psb_z_csc_reallocate_nz(nz,a) - import :: psb_ipk_, psb_z_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_z_csc_sparse_mat), intent(inout) :: a end subroutine psb_z_csc_reallocate_nz @@ -117,7 +172,7 @@ module psb_z_csc_mat_mod !| \see psb_base_mat_mod::psb_base_reinit interface subroutine psb_z_csc_reinit(a,clear) - import :: psb_ipk_, psb_z_csc_sparse_mat + import class(psb_z_csc_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_z_csc_reinit @@ -127,7 +182,7 @@ module psb_z_csc_mat_mod !| \see psb_base_mat_mod::psb_base_trim interface subroutine psb_z_csc_trim(a) - import :: psb_ipk_, psb_z_csc_sparse_mat + import class(psb_z_csc_sparse_mat), intent(inout) :: a end subroutine psb_z_csc_trim end interface @@ -136,7 +191,7 @@ module psb_z_csc_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_z_csc_mold(a,b,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ + import class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -147,7 +202,7 @@ module psb_z_csc_mat_mod !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface subroutine psb_z_csc_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_z_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_z_csc_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -159,7 +214,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_print interface subroutine psb_z_csc_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_z_csc_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -172,7 +227,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_to_coo interface subroutine psb_z_cp_csc_to_coo(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_csc_sparse_mat + import class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -183,7 +238,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo interface subroutine psb_z_cp_csc_from_coo(a,b,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_coo_sparse_mat + import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -194,7 +249,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_to_fmt interface subroutine psb_z_cp_csc_to_fmt(a,b,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -205,7 +260,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_from_fmt interface subroutine psb_z_cp_csc_from_fmt(a,b,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -216,7 +271,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_to_coo interface subroutine psb_z_mv_csc_to_coo(a,b,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_coo_sparse_mat + import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -227,7 +282,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_from_coo interface subroutine psb_z_mv_csc_from_coo(a,b,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_coo_sparse_mat + import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -238,7 +293,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_to_fmt interface subroutine psb_z_mv_csc_to_fmt(a,b,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -249,7 +304,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_from_fmt interface subroutine psb_z_mv_csc_from_fmt(a,b,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_csc_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -260,7 +315,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_from interface subroutine psb_z_csc_cp_from(a,b) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(inout) :: a type(psb_z_csc_sparse_mat), intent(in) :: b end subroutine psb_z_csc_cp_from @@ -270,7 +325,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_from interface subroutine psb_z_csc_mv_from(a,b) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(inout) :: a type(psb_z_csc_sparse_mat), intent(inout) :: b end subroutine psb_z_csc_mv_from @@ -281,7 +336,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csput_a interface subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -296,7 +351,7 @@ module psb_z_csc_mat_mod interface subroutine psb_z_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -328,28 +383,28 @@ module psb_z_csc_mat_mod end subroutine psb_z_csc_csgetrow end interface -!!$ !> \memberof psb_z_csc_sparse_mat -!!$ !! \see psb_z_base_mat_mod::psb_z_base_csgetblk -!!$ interface -!!$ subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& -!!$ & jmin,jmax,iren,append,rscale,cscale,chksz) -!!$ import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_, psb_z_coo_sparse_mat -!!$ class(psb_z_csc_sparse_mat), intent(in) :: a -!!$ class(psb_z_coo_sparse_mat), intent(inout) :: b -!!$ integer(psb_ipk_), intent(in) :: imin,imax -!!$ integer(psb_ipk_),intent(out) :: info -!!$ logical, intent(in), optional :: append -!!$ integer(psb_ipk_), intent(in), optional :: iren(:) -!!$ integer(psb_ipk_), intent(in), optional :: jmin,jmax -!!$ logical, intent(in), optional :: rscale,cscale,chksz -!!$ end subroutine psb_z_csc_csgetblk -!!$ end interface -!!$ + !> \memberof psb_z_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_z_base_csgetblk + interface + subroutine psb_z_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale,chksz) + import + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale,chksz + end subroutine psb_z_csc_csgetblk + end interface + !> \memberof psb_z_csc_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cssv interface subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -361,7 +416,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cssm interface subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -374,7 +429,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csmv interface subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -387,7 +442,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csmm interface subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -401,7 +456,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_maxval interface function psb_z_csc_maxval(a) result(res) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csc_maxval @@ -411,7 +466,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csnm1 interface function psb_z_csc_csnm1(a) result(res) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csc_csnm1 @@ -421,7 +476,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_rowsum interface subroutine psb_z_csc_rowsum(d,a) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csc_rowsum @@ -431,7 +486,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_arwsum interface subroutine psb_z_csc_arwsum(d,a) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csc_arwsum @@ -441,7 +496,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_colsum interface subroutine psb_z_csc_colsum(d,a) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csc_colsum @@ -451,7 +506,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_aclsum interface subroutine psb_z_csc_aclsum(d,a) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csc_aclsum @@ -461,7 +516,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_get_diag interface subroutine psb_z_csc_get_diag(a,d,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -472,7 +527,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_scal interface subroutine psb_z_csc_scal(d,a,info,side) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -484,7 +539,7 @@ module psb_z_csc_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_scals interface subroutine psb_z_csc_scals(d,a,info) - import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_ + import class(psb_z_csc_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -492,6 +547,347 @@ module psb_z_csc_mat_mod end interface + ! + ! lz + ! + !> \memberof psb_lz_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_lz_csc_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_csc_sparse_mat), intent(inout) :: a + end subroutine psb_lz_csc_reallocate_nz + end interface + + !> \memberof psb_lz_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_lz_csc_reinit(a,clear) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lz_csc_reinit + end interface + + !> \memberof psb_lz_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_lz_csc_trim(a) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + end subroutine psb_lz_csc_trim + end interface + + !> \memberof psb_lz_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_lz_csc_mold(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csc_mold + end interface + + !> \memberof psb_lz_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_lz_csc_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lz_csc_allocate_mnnz + end interface + + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_print + interface + subroutine psb_lz_csc_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_csc_print + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo + interface + subroutine psb_lz_cp_csc_to_coo(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csc_to_coo + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo + interface + subroutine psb_lz_cp_csc_from_coo(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csc_from_coo + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_fmt + interface + subroutine psb_lz_cp_csc_to_fmt(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csc_to_fmt + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_fmt + interface + subroutine psb_lz_cp_csc_from_fmt(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csc_from_fmt + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_coo + interface + subroutine psb_lz_mv_csc_to_coo(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csc_to_coo + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_coo + interface + subroutine psb_lz_mv_csc_from_coo(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csc_from_coo + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_fmt + interface + subroutine psb_lz_mv_csc_to_fmt(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csc_to_fmt + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_fmt + interface + subroutine psb_lz_mv_csc_from_fmt(a,b,info) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csc_from_fmt + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from + interface + subroutine psb_lz_csc_cp_from(a,b) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + type(psb_lz_csc_sparse_mat), intent(in) :: b + end subroutine psb_lz_csc_cp_from + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from + interface + subroutine psb_lz_csc_mv_from(a,b) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + type(psb_lz_csc_sparse_mat), intent(inout) :: b + end subroutine psb_lz_csc_mv_from + end interface + + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csput_a + interface + subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_csc_csput_a + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_lz_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csc_csgetptn + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csgetrow + interface + subroutine psb_lz_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csc_csgetrow + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csgetblk + interface + subroutine psb_lz_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csc_csgetblk + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_get_diag + interface + subroutine psb_lz_csc_get_diag(a,d,info) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csc_get_diag + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_maxval + interface + function psb_lz_csc_maxval(a) result(res) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csc_maxval + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_csnm1 + interface + function psb_lz_csc_csnm1(a) result(res) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csc_csnm1 + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_rowsum + interface + subroutine psb_lz_csc_rowsum(d,a) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csc_rowsum + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_arwsum + interface + subroutine psb_lz_csc_arwsum(d,a) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csc_arwsum + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_colsum + interface + subroutine psb_lz_csc_colsum(d,a) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csc_colsum + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_aclsum + interface + subroutine psb_lz_csc_aclsum(d,a) + import + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csc_aclsum + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scal + interface + subroutine psb_lz_csc_scal(d,a,info,side) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lz_csc_scal + end interface + + !> \memberof psb_lz_csc_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scals + interface + subroutine psb_lz_csc_scals(d,a,info) + import + class(psb_lz_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csc_scals + end interface + + + contains ! == =================================== @@ -519,11 +915,11 @@ contains function z_csc_sizeof(a) result(res) implicit none class(psb_z_csc_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + integer(psb_epk_) :: res + res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_dp) * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%icp) - res = res + psb_sizeof_int * psb_size(a%ia) + res = res + psb_sizeof_ip * psb_size(a%icp) + res = res + psb_sizeof_ip * psb_size(a%ia) end function z_csc_sizeof @@ -602,11 +998,133 @@ contains if (allocated(a%ia)) deallocate(a%ia) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) return end subroutine z_csc_free + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function lz_csc_is_by_cols(a) result(res) + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function lz_csc_is_by_cols + + ! + ! lz + ! + + function lz_csc_sizeof(a) result(res) + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2*psb_sizeof_lp + res = res + (2*psb_sizeof_dp) * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%icp) + res = res + psb_sizeof_lp * psb_size(a%ia) + + end function lz_csc_sizeof + + function lz_csc_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSC' + end function lz_csc_get_fmt + + function lz_csc_get_nzeros(a) result(res) + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%icp(a%get_ncols()+1)-1 + end function lz_csc_get_nzeros + + function lz_csc_get_size(a) result(res) + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ia)) then + res = size(a%ia) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function lz_csc_get_size + + + + function lz_csc_get_nz_col(idx,a) result(res) + use psb_const_mod + implicit none + + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_ncols())) then + res = a%icp(idx+1)-a%icp(idx) + end if + + end function lz_csc_get_nz_col + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + + subroutine lz_csc_free(a) + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + + if (allocated(a%icp)) deallocate(a%icp) + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine lz_csc_free + + + end module psb_z_csc_mat_mod diff --git a/base/modules/serial/psb_z_csr_mat_mod.f90 b/base/modules/serial/psb_z_csr_mat_mod.f90 index 7dc58c043..975ff9c9a 100644 --- a/base/modules/serial/psb_z_csr_mat_mod.f90 +++ b/base/modules/serial/psb_z_csr_mat_mod.f90 @@ -111,7 +111,7 @@ module psb_z_csr_mat_mod !| \see psb_base_mat_mod::psb_base_reallocate_nz interface subroutine psb_z_csr_reallocate_nz(nz,a) - import :: psb_ipk_, psb_z_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: nz class(psb_z_csr_sparse_mat), intent(inout) :: a end subroutine psb_z_csr_reallocate_nz @@ -121,7 +121,7 @@ module psb_z_csr_mat_mod !| \see psb_base_mat_mod::psb_base_reinit interface subroutine psb_z_csr_reinit(a,clear) - import :: psb_ipk_, psb_z_csr_sparse_mat + import class(psb_z_csr_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear end subroutine psb_z_csr_reinit @@ -131,7 +131,7 @@ module psb_z_csr_mat_mod !| \see psb_base_mat_mod::psb_base_trim interface subroutine psb_z_csr_trim(a) - import :: psb_ipk_, psb_z_csr_sparse_mat + import class(psb_z_csr_sparse_mat), intent(inout) :: a end subroutine psb_z_csr_trim end interface @@ -141,7 +141,7 @@ module psb_z_csr_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_z_csr_mold(a,b,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ + import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -152,7 +152,7 @@ module psb_z_csr_mat_mod !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) - import :: psb_ipk_, psb_z_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: m,n class(psb_z_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz @@ -164,7 +164,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_print interface subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_z_csr_sparse_mat + import integer(psb_ipk_), intent(in) :: iout class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in), optional :: iv(:) @@ -205,7 +205,7 @@ module psb_z_csr_mat_mod interface subroutine psb_z_csr_tril(a,l,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: l integer(psb_ipk_),intent(out) :: info @@ -249,7 +249,7 @@ module psb_z_csr_mat_mod interface subroutine psb_z_csr_triu(a,u,info,diag,imin,imax,& & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_coo_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(out) :: u integer(psb_ipk_),intent(out) :: info @@ -264,7 +264,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_to_coo interface subroutine psb_z_cp_csr_to_coo(a,b,info) - import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_csr_sparse_mat + import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -275,7 +275,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_from_coo interface subroutine psb_z_cp_csr_from_coo(a,b,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_coo_sparse_mat + import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -286,7 +286,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_to_fmt interface subroutine psb_z_cp_csr_to_fmt(a,b,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -297,7 +297,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_from_fmt interface subroutine psb_z_cp_csr_from_fmt(a,b,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info @@ -308,7 +308,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_to_coo interface subroutine psb_z_mv_csr_to_coo(a,b,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_coo_sparse_mat + import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -319,7 +319,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_from_coo interface subroutine psb_z_mv_csr_from_coo(a,b,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_coo_sparse_mat + import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -330,7 +330,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_to_fmt interface subroutine psb_z_mv_csr_to_fmt(a,b,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -341,7 +341,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_from_fmt interface subroutine psb_z_mv_csr_from_fmt(a,b,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_base_sparse_mat + import class(psb_z_csr_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info @@ -352,7 +352,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cp_from interface subroutine psb_z_csr_cp_from(a,b) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(inout) :: a type(psb_z_csr_sparse_mat), intent(in) :: b end subroutine psb_z_csr_cp_from @@ -362,7 +362,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_mv_from interface subroutine psb_z_csr_mv_from(a,b) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(inout) :: a type(psb_z_csr_sparse_mat), intent(inout) :: b end subroutine psb_z_csr_mv_from @@ -373,7 +373,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csput_a interface subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(in) :: nz,ia(:), ja(:),& @@ -388,7 +388,7 @@ module psb_z_csr_mat_mod interface subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -406,7 +406,7 @@ module psb_z_csr_mat_mod interface subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a integer(psb_ipk_), intent(in) :: imin,imax integer(psb_ipk_), intent(out) :: nz @@ -419,29 +419,12 @@ module psb_z_csr_mat_mod logical, intent(in), optional :: rscale,cscale,chksz end subroutine psb_z_csr_csgetrow end interface -!!$ -!!$ !> \memberof psb_z_csr_sparse_mat -!!$ !! \see psb_z_base_mat_mod::psb_z_base_csgetblk -!!$ interface -!!$ subroutine psb_z_csr_csgetblk(imin,imax,a,b,info,& -!!$ & jmin,jmax,iren,append,rscale,cscale) -!!$ import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_, psb_z_coo_sparse_mat -!!$ class(psb_z_csr_sparse_mat), intent(in) :: a -!!$ class(psb_z_coo_sparse_mat), intent(inout) :: b -!!$ integer(psb_ipk_), intent(in) :: imin,imax -!!$ integer(psb_ipk_),intent(out) :: info -!!$ logical, intent(in), optional :: append -!!$ integer(psb_ipk_), intent(in), optional :: iren(:) -!!$ integer(psb_ipk_), intent(in), optional :: jmin,jmax -!!$ logical, intent(in), optional :: rscale,cscale -!!$ end subroutine psb_z_csr_csgetblk -!!$ end interface - + !> \memberof psb_z_csr_sparse_mat !! \see psb_z_base_mat_mod::psb_z_base_cssv interface subroutine psb_z_csr_cssv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -453,7 +436,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_cssm interface subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -466,7 +449,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csmv interface subroutine psb_z_csr_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:) complex(psb_dpk_), intent(inout) :: y(:) @@ -479,7 +462,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csmm interface subroutine psb_z_csr_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) @@ -493,7 +476,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_maxval interface function psb_z_csr_maxval(a) result(res) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csr_maxval @@ -503,7 +486,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_csnmi interface function psb_z_csr_csnmi(a) result(res) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res end function psb_z_csr_csnmi @@ -513,7 +496,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_rowsum interface subroutine psb_z_csr_rowsum(d,a) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csr_rowsum @@ -523,7 +506,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_arwsum interface subroutine psb_z_csr_arwsum(d,a) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csr_arwsum @@ -533,7 +516,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_colsum interface subroutine psb_z_csr_colsum(d,a) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csr_colsum @@ -543,7 +526,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_aclsum interface subroutine psb_z_csr_aclsum(d,a) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) end subroutine psb_z_csr_aclsum @@ -553,7 +536,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_get_diag interface subroutine psb_z_csr_get_diag(a,d,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -564,7 +547,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_scal interface subroutine psb_z_csr_scal(d,a,info,side) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d(:) integer(psb_ipk_), intent(out) :: info @@ -576,7 +559,7 @@ module psb_z_csr_mat_mod !! \see psb_z_base_mat_mod::psb_z_base_scals interface subroutine psb_z_csr_scals(d,a,info) - import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_ + import class(psb_z_csr_sparse_mat), intent(inout) :: a complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info @@ -584,6 +567,471 @@ module psb_z_csr_mat_mod end interface + !> \namespace psb_base_mod \class psb_lz_csr_sparse_mat + !! \extends psb_lz_base_mat_mod::psb_lz_base_sparse_mat + !! + !! psb_lz_csr_sparse_mat type and the related methods. + !! This is a very common storage type, and is the default for assembled + !! matrices in our library + type, extends(psb_lz_base_sparse_mat) :: psb_lz_csr_sparse_mat + + !> Pointers to beginning of rows in JA and VAL. + integer(psb_lpk_), allocatable :: irp(:) + !> Column indices. + integer(psb_lpk_), allocatable :: ja(:) + !> Coefficient values. + complex(psb_dpk_), allocatable :: val(:) + + contains + procedure, pass(a) :: is_by_rows => lz_csr_is_by_rows + procedure, pass(a) :: get_size => lz_csr_get_size + procedure, pass(a) :: get_nzeros => lz_csr_get_nzeros + procedure, nopass :: get_fmt => lz_csr_get_fmt + procedure, pass(a) :: sizeof => lz_csr_sizeof + procedure, pass(a) :: reallocate_nz => psb_lz_csr_reallocate_nz + procedure, pass(a) :: allocate_mnnz => psb_lz_csr_allocate_mnnz + procedure, pass(a) :: tril => psb_lz_csr_tril + procedure, pass(a) :: triu => psb_lz_csr_triu + procedure, pass(a) :: cp_to_coo => psb_lz_cp_csr_to_coo + procedure, pass(a) :: cp_from_coo => psb_lz_cp_csr_from_coo + procedure, pass(a) :: cp_to_fmt => psb_lz_cp_csr_to_fmt + procedure, pass(a) :: cp_from_fmt => psb_lz_cp_csr_from_fmt + procedure, pass(a) :: mv_to_coo => psb_lz_mv_csr_to_coo + procedure, pass(a) :: mv_from_coo => psb_lz_mv_csr_from_coo + procedure, pass(a) :: mv_to_fmt => psb_lz_mv_csr_to_fmt + procedure, pass(a) :: mv_from_fmt => psb_lz_mv_csr_from_fmt + procedure, pass(a) :: csput_a => psb_lz_csr_csput_a + procedure, pass(a) :: get_diag => psb_lz_csr_get_diag + procedure, pass(a) :: csgetptn => psb_lz_csr_csgetptn + procedure, pass(a) :: csgetrow => psb_lz_csr_csgetrow + procedure, pass(a) :: get_nz_row => lz_csr_get_nz_row + procedure, pass(a) :: reinit => psb_lz_csr_reinit + procedure, pass(a) :: trim => psb_lz_csr_trim + procedure, pass(a) :: print => psb_lz_csr_print + procedure, pass(a) :: free => lz_csr_free + procedure, pass(a) :: mold => psb_lz_csr_mold + procedure, pass(a) :: scals => psb_lz_csr_scals + procedure, pass(a) :: scalv => psb_lz_csr_scal + procedure, pass(a) :: maxval => psb_lz_csr_maxval + procedure, pass(a) :: spnmi => psb_lz_csr_csnmi + procedure, pass(a) :: rowsum => psb_lz_csr_rowsum + procedure, pass(a) :: arwsum => psb_lz_csr_arwsum + procedure, pass(a) :: colsum => psb_lz_csr_colsum + procedure, pass(a) :: aclsum => psb_lz_csr_aclsum + + end type psb_lz_csr_sparse_mat + + private :: lz_csr_get_nzeros, lz_csr_free, lz_csr_get_fmt, & + & lz_csr_get_size, lz_csr_sizeof, lz_csr_get_nz_row, & + & lz_csr_is_by_rows + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reallocate_nz + interface + subroutine psb_lz_csr_reallocate_nz(nz,a) + import + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_csr_sparse_mat), intent(inout) :: a + end subroutine psb_lz_csr_reallocate_nz + end interface + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_reinit + interface + subroutine psb_lz_csr_reinit(a,clear) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lz_csr_reinit + end interface + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_trim + interface + subroutine psb_lz_csr_trim(a) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + end subroutine psb_lz_csr_trim + end interface + + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold + interface + subroutine psb_lz_csr_mold(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csr_mold + end interface + + !> \memberof psb_lz_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_allocate_mnnz + interface + subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) + import + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lz_csr_allocate_mnnz + end interface + + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_print + interface + subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) + import + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_csr_print + end interface + ! + !> Function tril: + !! \memberof psb_z_base_sparse_mat + !! \brief Copy the lower triangle, i.e. all entries + !! A(I,J) such that J-I <= DIAG + !! default value is DIAG=0, i.e. lower triangle up to + !! the main diagonal. + !! DIAG=-1 means copy the strictly lower triangle + !! DIAG= 1 means copy the lower triangle plus the first diagonal + !! of the upper triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! + !! \param l the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param u [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_lz_csr_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: u + end subroutine psb_lz_csr_tril + end interface + + ! + !> Function triu: + !! \memberof psb_z_csr_sparse_mat + !! \brief Copy the upper triangle, i.e. all entries + !! A(I,J) such that DIAG <= J-I + !! default value is DIAG=0, i.e. upper triangle from + !! the main diagonal up. + !! DIAG= 1 means copy the strictly upper triangle + !! DIAG=-1 means copy the upper triangle plus the first diagonal + !! of the lower triangle. + !! Moreover, apply a clipping by copying entries A(I,J) only if + !! IMIN<=I<=IMAX + !! JMIN<=J<=JMAX + !! Optionally copies the lower triangle at the same time + !! + !! \param u the output (sub)matrix + !! \param info return code + !! \param diag [0] the last diagonal (J-I) to be considered. + !! \param imin [1] the minimum row index we are interested in + !! \param imax [a\%get_nrows()] the minimum row index we are interested in + !! \param jmin [1] minimum col index + !! \param jmax [a\%get_ncols()] maximum col index + !! \param iren(:) [none] an array to return renumbered indices (iren(ia(:)),iren(ja(:)) + !! \param rscale [false] map [min(ia(:)):max(ia(:))] onto [1:max(ia(:))-min(ia(:))+1] + !! \param cscale [false] map [min(ja(:)):max(ja(:))] onto [1:max(ja(:))-min(ja(:))+1] + !! ( iren cannot be specified with rscale/cscale) + !! \param append [false] append to ia,ja + !! \param nzin [none] if append, then first new entry should go in entry nzin+1 + !! \param l [none] copy of the complementary triangle + !! + ! + interface + subroutine psb_lz_csr_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: l + end subroutine psb_lz_csr_triu + end interface + + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_coo + interface + subroutine psb_lz_cp_csr_to_coo(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csr_to_coo + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_coo + interface + subroutine psb_lz_cp_csr_from_coo(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csr_from_coo + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_to_fmt + interface + subroutine psb_lz_cp_csr_to_fmt(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csr_to_fmt + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from_fmt + interface + subroutine psb_lz_cp_csr_from_fmt(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_cp_csr_from_fmt + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_coo + interface + subroutine psb_lz_mv_csr_to_coo(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csr_to_coo + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_coo + interface + subroutine psb_lz_mv_csr_from_coo(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csr_from_coo + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_to_fmt + interface + subroutine psb_lz_mv_csr_to_fmt(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csr_to_fmt + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from_fmt + interface + subroutine psb_lz_mv_csr_from_fmt(a,b,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_mv_csr_from_fmt + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_cp_from + interface + subroutine psb_lz_csr_cp_from(a,b) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + type(psb_lz_csr_sparse_mat), intent(in) :: b + end subroutine psb_lz_csr_cp_from + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_mv_from + interface + subroutine psb_lz_csr_mv_from(a,b) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + type(psb_lz_csr_sparse_mat), intent(inout) :: b + end subroutine psb_lz_csr_mv_from + end interface + + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csput_a + interface + subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz,ia(:), ja(:),& + & imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_csr_csput_a + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_base_mat_mod::psb_base_csgetptn + interface + subroutine psb_lz_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csr_csgetptn + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_csgetrow + interface + subroutine psb_lz_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csr_csgetrow + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_get_diag + interface + subroutine psb_lz_csr_get_diag(a,d,info) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csr_get_diag + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scal + interface + subroutine psb_lz_csr_scal(d,a,info,side) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lz_csr_scal + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_lz_base_mat_mod::psb_lz_base_scals + interface + subroutine psb_lz_csr_scals(d,a,info) + import + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_csr_scals + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_maxval + interface + function psb_lz_csr_maxval(a) result(res) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csr_maxval + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_csnmi + interface + function psb_lz_csr_csnmi(a) result(res) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csr_csnmi + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_rowsum + interface + subroutine psb_lz_csr_rowsum(d,a) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csr_rowsum + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_arwsum + interface + subroutine psb_lz_csr_arwsum(d,a) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csr_arwsum + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_colsum + interface + subroutine psb_lz_csr_colsum(d,a) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csr_colsum + end interface + + !> \memberof psb_lz_csr_sparse_mat + !! \see psb_z_base_mat_mod::psb_lz_base_aclsum + interface + subroutine psb_lz_csr_aclsum(d,a) + import + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + end subroutine psb_lz_csr_aclsum + end interface + contains @@ -613,11 +1061,11 @@ contains function z_csr_sizeof(a) result(res) implicit none class(psb_z_csr_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res - res = 8 + integer(psb_epk_) :: res + res = 2 * psb_sizeof_ip res = res + (2*psb_sizeof_dp) * psb_size(a%val) - res = res + psb_sizeof_int * psb_size(a%irp) - res = res + psb_sizeof_int * psb_size(a%ja) + res = res + psb_sizeof_ip * psb_size(a%irp) + res = res + psb_sizeof_ip * psb_size(a%ja) end function z_csr_sizeof @@ -695,12 +1143,128 @@ contains if (allocated(a%ja)) deallocate(a%ja) if (allocated(a%val)) deallocate(a%val) call a%set_null() - call a%set_nrows(izero) - call a%set_ncols(izero) + call a%set_nrows(0_psb_ipk_) + call a%set_ncols(0_psb_ipk_) return end subroutine z_csr_free + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + + function lz_csr_is_by_rows(a) result(res) + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + logical :: res + res = .true. + + end function lz_csr_is_by_rows + + + function lz_csr_sizeof(a) result(res) + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_epk_) :: res + res = 2 * psb_sizeof_lp + res = res + (2*psb_sizeof_dp) * psb_size(a%val) + res = res + psb_sizeof_lp * psb_size(a%irp) + res = res + psb_sizeof_lp * psb_size(a%ja) + + end function lz_csr_sizeof + + function lz_csr_get_fmt() result(res) + implicit none + character(len=5) :: res + res = 'CSR' + end function lz_csr_get_fmt + + function lz_csr_get_nzeros(a) result(res) + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + res = a%irp(a%get_nrows()+1)-1 + end function lz_csr_get_nzeros + + function lz_csr_get_size(a) result(res) + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + res = -1 + + if (allocated(a%ja)) then + res = size(a%ja) + end if + if (allocated(a%val)) then + if (res >= 0) then + res = min(res,size(a%val)) + else + res = size(a%val) + end if + end if + + end function lz_csr_get_size + + + + function lz_csr_get_nz_row(idx,a) result(res) + + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + + res = 0 + + if ((1<=idx).and.(idx<=a%get_nrows())) then + res = a%irp(idx+1)-a%irp(idx) + end if + + end function lz_csr_get_nz_row + + + + ! == =================================== + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! + ! == =================================== + + subroutine lz_csr_free(a) + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + + if (allocated(a%irp)) deallocate(a%irp) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0_psb_lpk_) + call a%set_ncols(0_psb_lpk_) + + return + + end subroutine lz_csr_free + end module psb_z_csr_mat_mod diff --git a/base/modules/serial/psb_z_mat_mod.F90 b/base/modules/serial/psb_z_mat_mod.F90 new file mode 100644 index 000000000..6fc5bfe26 --- /dev/null +++ b/base/modules/serial/psb_z_mat_mod.F90 @@ -0,0 +1,2740 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! package: psb_z_mat_mod +! +! This module contains the definition of the psb_z_sparse type which +! is a generic container for a sparse matrix and it is mostly meant to +! provide a mean of switching, at run-time, among different formats, +! potentially unknown at the library compile-time by adding a layer of +! indirection. This type encapsulates the psb_z_base_sparse_mat class +! inside another class which is the one visible to the user. +! Most methods of the psb_z_mat_mod simply call the methods of the +! encapsulated class. +! The exceptions are mainly cscnv and cp_from/cp_to; these provide +! the functionalities to have the encapsulated class change its +! type dynamically, and to extract/input an inner object. +! +! A sparse matrix has a state corresponding to its progression +! through the application life. +! In particular, computational methods can only be invoked when +! the matrix is in the ASSEMBLED state, whereas the other states are +! dedicated to operations on the internal matrix data. +! A sparse matrix can move between states according to the +! following state transition table. Associated with these states are +! the possible dynamic types of the inner matrix object. +! Only COO matrices can ever be in the BUILD state, whereas +! the ASSEMBLED and UPDATE state can be entered by any class. +! +! In Out Method +!| ---------------------------------- +!| Null Build csall +!| Build Build csput +!| Build Assembled cscnv +!| Assembled Assembled cscnv +!| Assembled Update reinit +!| Update Update csput +!| Update Assembled cscnv +!| * unchanged reall +!| Assembled Null free +! +! +! +! We are also introducing the type psb_lzspmat_type. +! The basic difference with psb_zspmat_type is in the type +! of the indices, which are PSB_LPK_ so that the entries +! are guaranteed to be able to contain global indices. +! This type only supports data handling and preprocessing, it is +! not supposed to be used for computations. +! +module psb_z_mat_mod + + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat, psb_lz_csr_sparse_mat + use psb_z_csc_mat_mod, only : psb_z_csc_sparse_mat, psb_lz_csc_sparse_mat + + type :: psb_zspmat_type + + class(psb_z_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_z_get_nrows + procedure, pass(a) :: get_ncols => psb_z_get_ncols + procedure, pass(a) :: get_nzeros => psb_z_get_nzeros + procedure, pass(a) :: get_nz_row => psb_z_get_nz_row + procedure, pass(a) :: get_size => psb_z_get_size + procedure, pass(a) :: get_dupl => psb_z_get_dupl + procedure, pass(a) :: is_null => psb_z_is_null + procedure, pass(a) :: is_bld => psb_z_is_bld + procedure, pass(a) :: is_upd => psb_z_is_upd + procedure, pass(a) :: is_asb => psb_z_is_asb + procedure, pass(a) :: is_sorted => psb_z_is_sorted + procedure, pass(a) :: is_by_rows => psb_z_is_by_rows + procedure, pass(a) :: is_by_cols => psb_z_is_by_cols + procedure, pass(a) :: is_upper => psb_z_is_upper + procedure, pass(a) :: is_lower => psb_z_is_lower + procedure, pass(a) :: is_triangle => psb_z_is_triangle + procedure, pass(a) :: is_unit => psb_z_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_z_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_z_get_fmt + procedure, pass(a) :: sizeof => psb_z_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_z_set_nrows + procedure, pass(a) :: set_ncols => psb_z_set_ncols + procedure, pass(a) :: set_dupl => psb_z_set_dupl + procedure, pass(a) :: set_null => psb_z_set_null + procedure, pass(a) :: set_bld => psb_z_set_bld + procedure, pass(a) :: set_upd => psb_z_set_upd + procedure, pass(a) :: set_asb => psb_z_set_asb + procedure, pass(a) :: set_sorted => psb_z_set_sorted + procedure, pass(a) :: set_upper => psb_z_set_upper + procedure, pass(a) :: set_lower => psb_z_set_lower + procedure, pass(a) :: set_triangle => psb_z_set_triangle + procedure, pass(a) :: set_unit => psb_z_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_z_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_z_csall + procedure, pass(a) :: free => psb_z_free + procedure, pass(a) :: trim => psb_z_trim + procedure, pass(a) :: csput_a => psb_z_csput_a + procedure, pass(a) :: csput_v => psb_z_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_z_csgetptn + procedure, pass(a) :: csgetrow => psb_z_csgetrow + procedure, pass(a) :: csgetblk => psb_z_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: lcsgetptn => psb_z_lcsgetptn + procedure, pass(a) :: lcsgetrow => psb_z_lcsgetrow + generic, public :: csget => lcsgetptn, lcsgetrow +#endif + procedure, pass(a) :: tril => psb_z_tril + procedure, pass(a) :: triu => psb_z_triu + procedure, pass(a) :: m_csclip => psb_z_csclip + procedure, pass(a) :: b_csclip => psb_z_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_z_clean_zeros + procedure, pass(a) :: reall => psb_z_reallocate_nz + procedure, pass(a) :: get_neigh => psb_z_get_neigh + procedure, pass(a) :: reinit => psb_z_reinit + procedure, pass(a) :: print_i => psb_z_sparse_print + procedure, pass(a) :: print_n => psb_z_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_z_mold + procedure, pass(a) :: asb => psb_z_asb + procedure, pass(a) :: transp_1mat => psb_z_transp_1mat + procedure, pass(a) :: transp_2mat => psb_z_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_z_transc_1mat + procedure, pass(a) :: transc_2mat => psb_z_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => z_mat_sync + procedure, pass(a) :: is_host => z_mat_is_host + procedure, pass(a) :: is_dev => z_mat_is_dev + procedure, pass(a) :: is_sync => z_mat_is_sync + procedure, pass(a) :: set_host => z_mat_set_host + procedure, pass(a) :: set_dev => z_mat_set_dev + procedure, pass(a) :: set_sync => z_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_z_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_z_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_z_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_z_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: clip_d_ip => psb_z_clip_d_ip + procedure, pass(a) :: clip_d => psb_z_clip_d + generic, public :: clip_diag => clip_d_ip, clip_d + procedure, pass(a) :: cscnv_np => psb_z_cscnv + procedure, pass(a) :: cscnv_ip => psb_z_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_z_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_zspmat_clone + ! + ! To/from lz + ! + procedure, pass(a) :: mv_from_lb => psb_z_mv_from_lb + procedure, pass(a) :: mv_to_lb => psb_z_mv_to_lb + procedure, pass(a) :: cp_from_lb => psb_z_cp_from_lb + procedure, pass(a) :: cp_to_lb => psb_z_cp_to_lb + procedure, pass(a) :: mv_from_l => psb_z_mv_from_l + procedure, pass(a) :: mv_to_l => psb_z_mv_to_l + procedure, pass(a) :: cp_from_l => psb_z_cp_from_l + procedure, pass(a) :: cp_to_l => psb_z_cp_to_l + generic, public :: mv_from => mv_from_lb, mv_from_l + generic, public :: mv_to => mv_to_lb, mv_to_l + generic, public :: cp_from => cp_from_lb, cp_from_l + generic, public :: cp_to => cp_to_lb, cp_to_l + + ! Computational routines + procedure, pass(a) :: get_diag => psb_z_get_diag + procedure, pass(a) :: maxval => psb_z_maxval + procedure, pass(a) :: spnmi => psb_z_csnmi + procedure, pass(a) :: spnm1 => psb_z_csnm1 + procedure, pass(a) :: rowsum => psb_z_rowsum + procedure, pass(a) :: arwsum => psb_z_arwsum + procedure, pass(a) :: colsum => psb_z_colsum + procedure, pass(a) :: aclsum => psb_z_aclsum + procedure, pass(a) :: csmv_v => psb_z_csmv_vect + procedure, pass(a) :: csmv => psb_z_csmv + procedure, pass(a) :: csmm => psb_z_csmm + generic, public :: spmm => csmm, csmv, csmv_v + procedure, pass(a) :: scals => psb_z_scals + procedure, pass(a) :: scalv => psb_z_scal + generic, public :: scal => scals, scalv + procedure, pass(a) :: cssv_v => psb_z_cssv_vect + procedure, pass(a) :: cssv => psb_z_cssv + procedure, pass(a) :: cssm => psb_z_cssm + generic, public :: spsm => cssm, cssv, cssv_v + + end type psb_zspmat_type + + private :: psb_z_get_nrows, psb_z_get_ncols, & + & psb_z_get_nzeros, psb_z_get_size, & + & psb_z_get_dupl, psb_z_is_null, psb_z_is_bld, & + & psb_z_is_upd, psb_z_is_asb, psb_z_is_sorted, & + & psb_z_is_by_rows, psb_z_is_by_cols, psb_z_is_upper, & + & psb_z_is_lower, psb_z_is_triangle, psb_z_get_nz_row, & + & z_mat_sync, z_mat_is_host, z_mat_is_dev, & + & z_mat_is_sync, z_mat_set_host, z_mat_set_dev,& + & z_mat_set_sync + + + + class(psb_z_base_sparse_mat), allocatable, target, & + & save, private :: psb_z_base_mat_default + + interface psb_set_mat_default + module procedure psb_z_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_z_get_mat_default + end interface + + interface psb_sizeof + module procedure psb_z_sizeof + end interface + + + type :: psb_lzspmat_type + + class(psb_lz_base_sparse_mat), allocatable :: a + + contains + ! Getters + procedure, pass(a) :: get_nrows => psb_lz_get_nrows + procedure, pass(a) :: get_ncols => psb_lz_get_ncols + procedure, pass(a) :: get_nzeros => psb_lz_get_nzeros + procedure, pass(a) :: get_nz_row => psb_lz_get_nz_row + procedure, pass(a) :: get_size => psb_lz_get_size + procedure, pass(a) :: get_dupl => psb_lz_get_dupl + procedure, pass(a) :: is_null => psb_lz_is_null + procedure, pass(a) :: is_bld => psb_lz_is_bld + procedure, pass(a) :: is_upd => psb_lz_is_upd + procedure, pass(a) :: is_asb => psb_lz_is_asb + procedure, pass(a) :: is_sorted => psb_lz_is_sorted + procedure, pass(a) :: is_by_rows => psb_lz_is_by_rows + procedure, pass(a) :: is_by_cols => psb_lz_is_by_cols + procedure, pass(a) :: is_upper => psb_lz_is_upper + procedure, pass(a) :: is_lower => psb_lz_is_lower + procedure, pass(a) :: is_triangle => psb_lz_is_triangle + procedure, pass(a) :: is_unit => psb_lz_is_unit + procedure, pass(a) :: is_repeatable_updates => psb_lz_is_repeatable_updates + procedure, pass(a) :: get_fmt => psb_lz_get_fmt + procedure, pass(a) :: sizeof => psb_lz_sizeof + + ! Setters + procedure, pass(a) :: set_nrows => psb_lz_set_nrows + procedure, pass(a) :: set_ncols => psb_lz_set_ncols + procedure, pass(a) :: set_dupl => psb_lz_set_dupl + procedure, pass(a) :: set_null => psb_lz_set_null + procedure, pass(a) :: set_bld => psb_lz_set_bld + procedure, pass(a) :: set_upd => psb_lz_set_upd + procedure, pass(a) :: set_asb => psb_lz_set_asb + procedure, pass(a) :: set_sorted => psb_lz_set_sorted + procedure, pass(a) :: set_upper => psb_lz_set_upper + procedure, pass(a) :: set_lower => psb_lz_set_lower + procedure, pass(a) :: set_triangle => psb_lz_set_triangle + procedure, pass(a) :: set_unit => psb_lz_set_unit + procedure, pass(a) :: set_repeatable_updates => psb_lz_set_repeatable_updates + + ! Memory/data management + procedure, pass(a) :: csall => psb_lz_csall + procedure, pass(a) :: free => psb_lz_free + procedure, pass(a) :: trim => psb_lz_trim + procedure, pass(a) :: csput_a => psb_lz_csput_a + procedure, pass(a) :: csput_v => psb_lz_csput_v + generic, public :: csput => csput_a, csput_v + procedure, pass(a) :: csgetptn => psb_lz_csgetptn + procedure, pass(a) :: csgetrow => psb_lz_csgetrow + procedure, pass(a) :: csgetblk => psb_lz_csgetblk + generic, public :: csget => csgetptn, csgetrow, csgetblk +#if defined(IPK4) && defined(LPK8) + procedure, pass(a) :: icsgetptn => psb_lz_icsgetptn + procedure, pass(a) :: icsgetrow => psb_lz_icsgetrow + generic, public :: csget => icsgetptn, icsgetrow +#endif + procedure, pass(a) :: tril => psb_lz_tril + procedure, pass(a) :: triu => psb_lz_triu + procedure, pass(a) :: m_csclip => psb_lz_csclip + procedure, pass(a) :: b_csclip => psb_lz_b_csclip + generic, public :: csclip => b_csclip, m_csclip + procedure, pass(a) :: clean_zeros => psb_lz_clean_zeros + procedure, pass(a) :: reall => psb_lz_reallocate_nz + procedure, pass(a) :: get_neigh => psb_lz_get_neigh + procedure, pass(a) :: reinit => psb_lz_reinit + procedure, pass(a) :: print_i => psb_lz_sparse_print + procedure, pass(a) :: print_n => psb_lz_n_sparse_print + generic, public :: print => print_i, print_n + procedure, pass(a) :: mold => psb_lz_mold + procedure, pass(a) :: asb => psb_lz_asb + procedure, pass(a) :: transp_1mat => psb_lz_transp_1mat + procedure, pass(a) :: transp_2mat => psb_lz_transp_2mat + generic, public :: transp => transp_1mat, transp_2mat + procedure, pass(a) :: transc_1mat => psb_lz_transc_1mat + procedure, pass(a) :: transc_2mat => psb_lz_transc_2mat + generic, public :: transc => transc_1mat, transc_2mat + + ! + ! Sync: centerpiece of handling of external storage. + ! Any derived class having extra storage upon sync + ! will guarantee that both fortran/host side and + ! external side contain the same data. The base + ! version is only a placeholder. + ! + procedure, pass(a) :: sync => lz_mat_sync + procedure, pass(a) :: is_host => lz_mat_is_host + procedure, pass(a) :: is_dev => lz_mat_is_dev + procedure, pass(a) :: is_sync => lz_mat_is_sync + procedure, pass(a) :: set_host => lz_mat_set_host + procedure, pass(a) :: set_dev => lz_mat_set_dev + procedure, pass(a) :: set_sync => lz_mat_set_sync + + + ! These are specific to this level of encapsulation. + procedure, pass(a) :: mv_from_b => psb_lz_mv_from + generic, public :: mv_from => mv_from_b + procedure, pass(a) :: mv_to_b => psb_lz_mv_to + generic, public :: mv_to => mv_to_b + procedure, pass(a) :: cp_from_b => psb_lz_cp_from + generic, public :: cp_from => cp_from_b + procedure, pass(a) :: cp_to_b => psb_lz_cp_to + generic, public :: cp_to => cp_to_b + procedure, pass(a) :: cscnv_np => psb_lz_cscnv + procedure, pass(a) :: cscnv_ip => psb_lz_cscnv_ip + procedure, pass(a) :: cscnv_base => psb_lz_cscnv_base + generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: clone => psb_lzspmat_clone + ! + ! To/from z + ! + procedure, pass(a) :: mv_from_ib => psb_lz_mv_from_ib + procedure, pass(a) :: mv_to_ib => psb_lz_mv_to_ib + procedure, pass(a) :: cp_from_ib => psb_lz_cp_from_ib + procedure, pass(a) :: cp_to_ib => psb_lz_cp_to_ib + procedure, pass(a) :: mv_from_i => psb_lz_mv_from_i + procedure, pass(a) :: mv_to_i => psb_lz_mv_to_i + procedure, pass(a) :: cp_from_i => psb_lz_cp_from_i + procedure, pass(a) :: cp_to_i => psb_lz_cp_to_i + generic, public :: mv_from => mv_from_ib, mv_from_i + generic, public :: mv_to => mv_to_ib, mv_to_i + generic, public :: cp_from => cp_from_ib, cp_from_i + generic, public :: cp_to => cp_to_ib, cp_to_i + + ! Computational routines + procedure, pass(a) :: get_diag => psb_lz_get_diag + procedure, pass(a) :: maxval => psb_lz_maxval + procedure, pass(a) :: spnmi => psb_lz_csnmi + procedure, pass(a) :: spnm1 => psb_lz_csnm1 + procedure, pass(a) :: rowsum => psb_lz_rowsum + procedure, pass(a) :: arwsum => psb_lz_arwsum + procedure, pass(a) :: colsum => psb_lz_colsum + procedure, pass(a) :: aclsum => psb_lz_aclsum + procedure, pass(a) :: scals => psb_lz_scals + procedure, pass(a) :: scalv => psb_lz_scal + generic, public :: scal => scals, scalv + + end type psb_lzspmat_type + + private :: psb_lz_get_nrows, psb_lz_get_ncols, & + & psb_lz_get_nzeros, psb_lz_get_size, & + & psb_lz_get_dupl, psb_lz_is_null, psb_lz_is_bld, & + & psb_lz_is_upd, psb_lz_is_asb, psb_lz_is_sorted, & + & psb_lz_is_by_rows, psb_lz_is_by_cols, psb_lz_is_upper, & + & psb_lz_is_lower, psb_lz_is_triangle, psb_lz_get_nz_row, & + & lz_mat_sync, lz_mat_is_host, lz_mat_is_dev, & + & lz_mat_is_sync, lz_mat_set_host, lz_mat_set_dev,& + & lz_mat_set_sync + + + + class(psb_lz_base_sparse_mat), allocatable, target, & + & save, private :: psb_lz_base_mat_default + + interface psb_set_mat_default + module procedure psb_lz_set_mat_default + end interface + + interface psb_get_mat_default + module procedure psb_lz_get_mat_default + end interface + + + ! == =================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == =================================== + + + interface + subroutine psb_z_set_nrows(m,a) + import :: psb_ipk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: m + end subroutine psb_z_set_nrows + end interface + + interface + subroutine psb_z_set_ncols(n,a) + import :: psb_ipk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_z_set_ncols + end interface + + interface + subroutine psb_z_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_z_set_dupl + end interface + + interface + subroutine psb_z_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_set_null + end interface + + interface + subroutine psb_z_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_set_bld + end interface + + interface + subroutine psb_z_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_set_upd + end interface + + interface + subroutine psb_z_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_set_asb + end interface + + interface + subroutine psb_z_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_sorted + end interface + + interface + subroutine psb_z_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_triangle + end interface + + interface + subroutine psb_z_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_unit + end interface + + interface + subroutine psb_z_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_lower + end interface + + interface + subroutine psb_z_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_z_set_upper + end interface + + interface + subroutine psb_z_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_z_sparse_print + end interface + + interface + subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + character(len=*), intent(in) :: fname + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_z_n_sparse_print + end interface + + interface + subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: idx + integer(psb_ipk_), intent(out) :: n + integer(psb_ipk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: lev + end subroutine psb_z_get_neigh + end interface + + interface + subroutine psb_z_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: nz + end subroutine psb_z_csall + end interface + + interface + subroutine psb_z_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + integer(psb_ipk_), intent(in) :: nz + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_reallocate_nz + end interface + + interface + subroutine psb_z_free(a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_free + end interface + + interface + subroutine psb_z_trim(a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_trim + end interface + + interface + subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_z_csput_a + end interface + + + interface + subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_vect_mod, only : psb_z_vect_type + use psb_i_vect_mod, only : psb_i_vect_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + type(psb_z_vect_type), intent(inout) :: val + type(psb_i_vect_type), intent(inout) :: ia, ja + integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + end subroutine psb_z_csput_v + end interface + + interface + subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csgetptn + end interface + + interface + subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csgetrow + end interface + + interface + subroutine psb_z_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csgetblk + end interface + + interface + subroutine psb_z_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_zspmat_type), optional, intent(inout) :: u + end subroutine psb_z_tril + end interface + + interface + subroutine psb_z_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_zspmat_type), optional, intent(inout) :: l + end subroutine psb_z_triu + end interface + + + interface + subroutine psb_z_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_csclip + end interface + + interface + subroutine psb_z_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_coo_sparse_mat + class(psb_zspmat_type), intent(in) :: a + type(psb_z_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_z_b_csclip + end interface + + interface + subroutine psb_z_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_z_mold + end interface + + interface + subroutine psb_z_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_z_asb + end interface + + interface + subroutine psb_z_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_transp_1mat + end interface + + interface + subroutine psb_z_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: b + end subroutine psb_z_transp_2mat + end interface + + interface + subroutine psb_z_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + end subroutine psb_z_transc_1mat + end interface + + interface + subroutine psb_z_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: b + end subroutine psb_z_transc_2mat + end interface + + interface + subroutine psb_z_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_z_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_z_cscnv + end interface + + + interface + subroutine psb_z_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_z_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_z_cscnv_ip + end interface + + + interface + subroutine psb_z_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(in) :: a + class(psb_z_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_z_cscnv_base + end interface + + ! + ! Produce a version of the matrix with diagonal cut + ! out; passes through a COO buffer. + ! + interface + subroutine psb_z_clip_d(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + end subroutine psb_z_clip_d + end interface + + interface + subroutine psb_z_clip_d_ip(a,info) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + end subroutine psb_z_clip_d_ip + end interface + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_z_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + end subroutine psb_z_mv_from + end interface + + interface + subroutine psb_z_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(out) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + end subroutine psb_z_cp_from + end interface + + interface + subroutine psb_z_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + end subroutine psb_z_mv_to + end interface + + interface + subroutine psb_z_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_zspmat_type), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + end subroutine psb_z_cp_to + end interface + ! + ! Mixed type conversions + ! + interface + subroutine psb_z_mv_from_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_zspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_z_mv_from_lb + end interface + + interface + subroutine psb_z_cp_from_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_zspmat_type), intent(out) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + end subroutine psb_z_cp_from_lb + end interface + + interface + subroutine psb_z_mv_to_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_zspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_z_mv_to_lb + end interface + + interface + subroutine psb_z_cp_to_lb(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_zspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_z_cp_to_lb + end interface + + interface + subroutine psb_z_mv_from_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lzspmat_type + class(psb_zspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + end subroutine psb_z_mv_from_l + end interface + + interface + subroutine psb_z_cp_from_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lzspmat_type + class(psb_zspmat_type), intent(out) :: a + class(psb_lzspmat_type), intent(in) :: b + end subroutine psb_z_cp_from_l + end interface + + interface + subroutine psb_z_mv_to_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lzspmat_type + class(psb_zspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + end subroutine psb_z_mv_to_l + end interface + + interface + subroutine psb_z_cp_to_l(a,b) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_lzspmat_type + class(psb_zspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + end subroutine psb_z_cp_to_l + end interface + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_zspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zspmat_type_move + end interface + + interface + subroutine psb_zspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zspmat_clone + end interface + + + + + ! == =================================== + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! + ! == =================================== + + interface psb_csmm + subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_csmm + subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_csmv + subroutine psb_z_csmv_vect(alpha,a,x,beta,y,info,trans) + use psb_z_vect_mod, only : psb_z_vect_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_z_vect_type), intent(inout) :: x + type(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans + end subroutine psb_z_csmv_vect + end interface + + interface psb_cssm + subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) + complex(psb_dpk_), intent(inout) :: y(:,:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_z_cssm + subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta, x(:) + complex(psb_dpk_), intent(inout) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + complex(psb_dpk_), intent(in), optional :: d(:) + end subroutine psb_z_cssv + subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) + use psb_z_vect_mod, only : psb_z_vect_type + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), intent(in) :: alpha, beta + type(psb_z_vect_type), intent(inout) :: x + type(psb_z_vect_type), intent(inout) :: y + integer(psb_ipk_), intent(out) :: info + character, optional, intent(in) :: trans, scale + type(psb_z_vect_type), optional, intent(inout) :: d + end subroutine psb_z_cssv_vect + end interface + + interface + function psb_z_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_z_maxval + end interface + + interface + function psb_z_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_z_csnmi + end interface + + interface + function psb_z_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_z_csnm1 + end interface + + interface + function psb_z_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_z_rowsum + end interface + + interface + function psb_z_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_z_arwsum + end interface + + interface + function psb_z_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_z_colsum + end interface + + interface + function psb_z_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_z_aclsum + end interface + + interface + function psb_z_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_z_get_diag + end interface + + interface psb_scal + subroutine psb_z_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_z_scal + subroutine psb_z_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_ + class(psb_zspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_scals + end interface + + + ! == =================================== + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! + ! == =================================== + + + interface + subroutine psb_lz_set_nrows(m,a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + end subroutine psb_lz_set_nrows + end interface + + interface + subroutine psb_lz_set_ncols(n,a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + end subroutine psb_lz_set_ncols + end interface + + interface + subroutine psb_lz_set_dupl(n,a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + end subroutine psb_lz_set_dupl + end interface + + interface + subroutine psb_lz_set_null(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_set_null + end interface + + interface + subroutine psb_lz_set_bld(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_set_bld + end interface + + interface + subroutine psb_lz_set_upd(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_set_upd + end interface + + interface + subroutine psb_lz_set_asb(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_set_asb + end interface + + interface + subroutine psb_lz_set_sorted(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_sorted + end interface + + interface + subroutine psb_lz_set_triangle(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_triangle + end interface + + interface + subroutine psb_lz_set_unit(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_unit + end interface + + interface + subroutine psb_lz_set_lower(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_lower + end interface + + interface + subroutine psb_lz_set_upper(a,val) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + end subroutine psb_lz_set_upper + end interface + + interface + subroutine psb_lz_sparse_print(iout,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + integer(psb_ipk_), intent(in) :: iout + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_sparse_print + end interface + + interface + subroutine psb_lz_n_sparse_print(fname,a,iv,head,ivr,ivc) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + character(len=*), intent(in) :: fname + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + end subroutine psb_lz_n_sparse_print + end interface + + interface + subroutine psb_lz_get_neigh(a,idx,neigh,n,info,lev) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + end subroutine psb_lz_get_neigh + end interface + + interface + subroutine psb_lz_csall(nr,nc,a,info,nz) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + end subroutine psb_lz_csall + end interface + + interface + subroutine psb_lz_reallocate_nz(nz,a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + integer(psb_lpk_), intent(in) :: nz + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_reallocate_nz + end interface + + interface + subroutine psb_lz_free(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_free + end interface + + interface + subroutine psb_lz_trim(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_trim + end interface + + interface + subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_csput_a + end interface + + + interface + subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_vect_mod, only : psb_z_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + type(psb_z_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + end subroutine psb_lz_csput_v + end interface + + interface + subroutine psb_lz_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csgetptn + end interface + + interface + subroutine psb_lz_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csgetrow + end interface + + interface + subroutine psb_lz_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csgetblk + end interface + + interface + subroutine psb_lz_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lzspmat_type), optional, intent(inout) :: u + end subroutine psb_lz_tril + end interface + + interface + subroutine psb_lz_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lzspmat_type), optional, intent(inout) :: l + end subroutine psb_lz_triu + end interface + + + interface + subroutine psb_lz_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_csclip + end interface + + interface + subroutine psb_lz_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_coo_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + type(psb_lz_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + end subroutine psb_lz_b_csclip + end interface + + interface + subroutine psb_lz_mold(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), allocatable, intent(out) :: b + end subroutine psb_lz_mold + end interface + + interface + subroutine psb_lz_asb(a,mold) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), optional, intent(in) :: mold + end subroutine psb_lz_asb + end interface + + interface + subroutine psb_lz_transp_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_transp_1mat + end interface + + interface + subroutine psb_lz_transp_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + end subroutine psb_lz_transp_2mat + end interface + + interface + subroutine psb_lz_transc_1mat(a) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + end subroutine psb_lz_transc_1mat + end interface + + interface + subroutine psb_lz_transc_2mat(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + end subroutine psb_lz_transc_2mat + end interface + + interface + subroutine psb_lz_reinit(a,clear) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + end subroutine psb_lz_reinit + + end interface + + + ! + ! These methods are specific to the outer SPMAT_TYPE level, since + ! they tamper with the inner BASE_SPARSE_MAT object. + ! + ! + + ! + ! CSCNV: switches to a different internal derived type. + ! 3 versions: copying to target + ! copying to a base_sparse_mat object. + ! in place + ! + ! + interface + subroutine psb_lz_cscnv(a,b,info,type,mold,upd,dupl) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_lz_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_lz_cscnv + end interface + + + interface + subroutine psb_lz_cscnv_ip(a,iinfo,type,mold,dupl) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iinfo + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_lz_base_sparse_mat), intent(in), optional :: mold + end subroutine psb_lz_cscnv_ip + end interface + + + interface + subroutine psb_lz_cscnv_base(a,b,info,dupl) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + end subroutine psb_lz_cscnv_base + end interface + + + ! + ! These four interfaces cut through the + ! encapsulation between spmat_type and base_sparse_mat. + ! + interface + subroutine psb_lz_mv_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_mv_from + end interface + + interface + subroutine psb_lz_cp_from(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(out) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + end subroutine psb_lz_cp_from + end interface + + interface + subroutine psb_lz_mv_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_mv_to + end interface + + interface + subroutine psb_lz_cp_to(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_lz_base_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_cp_to + end interface + ! + ! Mixed type conversions + ! + interface + subroutine psb_lz_mv_from_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_mv_from_ib + end interface + + interface + subroutine psb_lz_cp_from_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_lzspmat_type), intent(out) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + end subroutine psb_lz_cp_from_ib + end interface + + interface + subroutine psb_lz_mv_to_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_lzspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_mv_to_ib + end interface + + interface + subroutine psb_lz_cp_to_ib(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_z_base_sparse_mat + class(psb_lzspmat_type), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + end subroutine psb_lz_cp_to_ib + end interface + + interface + subroutine psb_lz_mv_from_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_zspmat_type + class(psb_lzspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + end subroutine psb_lz_mv_from_i + end interface + + interface + subroutine psb_lz_cp_from_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_zspmat_type + class(psb_lzspmat_type), intent(out) :: a + class(psb_zspmat_type), intent(in) :: b + end subroutine psb_lz_cp_from_i + end interface + + interface + subroutine psb_lz_mv_to_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_zspmat_type + class(psb_lzspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + end subroutine psb_lz_mv_to_i + end interface + + interface + subroutine psb_lz_cp_to_i(a,b) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_, psb_zspmat_type + class(psb_lzspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: b + end subroutine psb_lz_cp_to_i + end interface + + + ! + ! Transfer the internal allocation to the target. + ! + interface psb_move_alloc + subroutine psb_lzspmat_type_move(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzspmat_type_move + end interface + + interface + subroutine psb_lzspmat_clone(a,b,info) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzspmat_clone + end interface + + + + interface + function psb_lz_get_diag(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_get_diag + end interface + + interface psb_scal + subroutine psb_lz_scal(d,a,info,side) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + end subroutine psb_lz_scal + subroutine psb_lz_scals(d,a,info) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lz_scals + end interface + + interface + function psb_lz_maxval(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_maxval + end interface + + interface + function psb_lz_csnmi(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csnmi + end interface + + interface + function psb_lz_csnm1(a) result(res) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + end function psb_lz_csnm1 + end interface + + interface + function psb_lz_rowsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_rowsum + end interface + + interface + function psb_lz_arwsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_arwsum + end interface + + interface + function psb_lz_colsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_colsum + end interface + + interface + function psb_lz_aclsum(a,info) result(d) + import :: psb_ipk_, psb_lpk_, psb_lzspmat_type, psb_dpk_ + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + end function psb_lz_aclsum + end interface + +contains + + subroutine psb_z_set_mat_default(a) + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + + if (allocated(psb_z_base_mat_default)) then + deallocate(psb_z_base_mat_default) + end if + allocate(psb_z_base_mat_default, mold=a) + + end subroutine psb_z_set_mat_default + + function psb_z_get_mat_default(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + class(psb_z_base_sparse_mat), pointer :: res + + res => psb_z_get_base_mat_default() + + end function psb_z_get_mat_default + + + function psb_z_get_base_mat_default() result(res) + implicit none + class(psb_z_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_z_base_mat_default)) then + allocate(psb_z_csr_sparse_mat :: psb_z_base_mat_default) + end if + + res => psb_z_base_mat_default + + end function psb_z_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_z_sizeof(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_z_sizeof + + + function psb_z_get_fmt(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_z_get_fmt + + + function psb_z_get_dupl(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_z_get_dupl + + function psb_z_get_nrows(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_z_get_nrows + + function psb_z_get_ncols(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_z_get_ncols + + function psb_z_is_triangle(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_z_is_triangle + + function psb_z_is_unit(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_z_is_unit + + function psb_z_is_upper(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_z_is_upper + + function psb_z_is_lower(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_z_is_lower + + function psb_z_is_null(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_z_is_null + + function psb_z_is_bld(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_z_is_bld + + function psb_z_is_upd(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_z_is_upd + + function psb_z_is_asb(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_z_is_asb + + function psb_z_is_sorted(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_z_is_sorted + + function psb_z_is_by_rows(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_z_is_by_rows + + function psb_z_is_by_cols(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_z_is_by_cols + + + ! + subroutine z_mat_sync(a) + implicit none + class(psb_zspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine z_mat_sync + + ! + subroutine z_mat_set_host(a) + implicit none + class(psb_zspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine z_mat_set_host + + + ! + subroutine z_mat_set_dev(a) + implicit none + class(psb_zspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine z_mat_set_dev + + ! + subroutine z_mat_set_sync(a) + implicit none + class(psb_zspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine z_mat_set_sync + + ! + function z_mat_is_dev(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function z_mat_is_dev + + ! + function z_mat_is_host(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function z_mat_is_host + + ! + function z_mat_is_sync(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function z_mat_is_sync + + + function psb_z_is_repeatable_updates(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_z_is_repeatable_updates + + subroutine psb_z_set_repeatable_updates(a,val) + implicit none + class(psb_zspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_z_set_repeatable_updates + + + function psb_z_get_nzeros(a) result(res) + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_z_get_nzeros + + function psb_z_get_size(a) result(res) + + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_z_get_size + + + function psb_z_get_nz_row(idx,a) result(res) + implicit none + integer(psb_ipk_), intent(in) :: idx + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_z_get_nz_row + + subroutine psb_z_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_zspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_z_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_z_lcsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_z_lcsgetptn + + subroutine psb_z_lcsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_zspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_z_lcsgetrow +#endif + + ! + ! lz methods + ! + + + subroutine psb_lz_set_mat_default(a) + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + + if (allocated(psb_lz_base_mat_default)) then + deallocate(psb_lz_base_mat_default) + end if + allocate(psb_lz_base_mat_default, mold=a) + + end subroutine psb_lz_set_mat_default + + function psb_lz_get_mat_default(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), pointer :: res + + res => psb_lz_get_base_mat_default() + + end function psb_lz_get_mat_default + + + function psb_lz_get_base_mat_default() result(res) + implicit none + class(psb_lz_base_sparse_mat), pointer :: res + + if (.not.allocated(psb_lz_base_mat_default)) then + allocate(psb_lz_csr_sparse_mat :: psb_lz_base_mat_default) + end if + + res => psb_lz_base_mat_default + + end function psb_lz_get_base_mat_default + + + + + ! == =================================== + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! + ! == =================================== + + + function psb_lz_sizeof(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_epk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%sizeof() + end if + + end function psb_lz_sizeof + + + function psb_lz_get_fmt(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + character(len=5) :: res + + if (allocated(a%a)) then + res = a%a%get_fmt() + else + res = 'NULL' + end if + + end function psb_lz_get_fmt + + + function psb_lz_get_dupl(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_ipk_) :: res + + if (allocated(a%a)) then + res = a%a%get_dupl() + else + res = psb_invalid_ + end if + end function psb_lz_get_dupl + + function psb_lz_get_nrows(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_nrows() + else + res = 0 + end if + + end function psb_lz_get_nrows + + function psb_lz_get_ncols(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + if (allocated(a%a)) then + res = a%a%get_ncols() + else + res = 0 + end if + + end function psb_lz_get_ncols + + function psb_lz_is_triangle(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_triangle() + else + res = .false. + end if + + end function psb_lz_is_triangle + + function psb_lz_is_unit(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_unit() + else + res = .false. + end if + + end function psb_lz_is_unit + + function psb_lz_is_upper(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upper() + else + res = .false. + end if + + end function psb_lz_is_upper + + function psb_lz_is_lower(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = .not. a%a%is_upper() + else + res = .false. + end if + + end function psb_lz_is_lower + + function psb_lz_is_null(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_null() + else + res = .true. + end if + + end function psb_lz_is_null + + function psb_lz_is_bld(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_bld() + else + res = .false. + end if + + end function psb_lz_is_bld + + function psb_lz_is_upd(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_upd() + else + res = .false. + end if + + end function psb_lz_is_upd + + function psb_lz_is_asb(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_asb() + else + res = .false. + end if + + end function psb_lz_is_asb + + function psb_lz_is_sorted(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_sorted() + else + res = .false. + end if + + end function psb_lz_is_sorted + + function psb_lz_is_by_rows(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_rows() + else + res = .false. + end if + + end function psb_lz_is_by_rows + + function psb_lz_is_by_cols(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_by_cols() + else + res = .false. + end if + + end function psb_lz_is_by_cols + + + ! + subroutine lz_mat_sync(a) + implicit none + class(psb_lzspmat_type), target, intent(in) :: a + + if (allocated(a%a)) call a%a%sync() + + end subroutine lz_mat_sync + + ! + subroutine lz_mat_set_host(a) + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_host() + + end subroutine lz_mat_set_host + + + ! + subroutine lz_mat_set_dev(a) + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_dev() + + end subroutine lz_mat_set_dev + + ! + subroutine lz_mat_set_sync(a) + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + if (allocated(a%a)) call a%a%set_sync() + + end subroutine lz_mat_set_sync + + ! + function lz_mat_is_dev(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_dev() + else + res = .false. + end if + end function lz_mat_is_dev + + ! + function lz_mat_is_host(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_host() + else + res = .true. + end if + end function lz_mat_is_host + + ! + function lz_mat_is_sync(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + + if (allocated(a%a)) then + res = a%a%is_sync() + else + res = .true. + end if + + end function lz_mat_is_sync + + + function psb_lz_is_repeatable_updates(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + logical :: res + + if (allocated(a%a)) then + res = a%a%is_repeatable_updates() + else + res = .false. + end if + + end function psb_lz_is_repeatable_updates + + subroutine psb_lz_set_repeatable_updates(a,val) + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + + if (allocated(a%a)) then + call a%a%set_repeatable_updates(val) + end if + + end subroutine psb_lz_set_repeatable_updates + + + function psb_lz_get_nzeros(a) result(res) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + if (allocated(a%a)) then + res = a%a%get_nzeros() + end if + + end function psb_lz_get_nzeros + + function psb_lz_get_size(a) result(res) + + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + + res = 0 + if (allocated(a%a)) then + res = a%a%get_size() + end if + + end function psb_lz_get_size + + + function psb_lz_get_nz_row(idx,a) result(res) + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_) :: res + + res = 0 + + if (allocated(a%a)) res = a%a%get_nz_row(idx) + + end function psb_lz_get_nz_row + + subroutine psb_lz_clean_zeros(a,info) + implicit none + integer(psb_ipk_), intent(out) :: info + class(psb_lzspmat_type), intent(inout) :: a + + info = 0 + if (allocated(a%a)) call a%a%clean_zeros(info) + + end subroutine psb_lz_clean_zeros + +#if defined(IPK4) && defined(LPK8) + subroutine psb_lz_icsgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + info = psb_success_ + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + call a%csget(imin,imax,nz,lia,lja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_lz_icsgetptn + + subroutine psb_lz_icsgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_ipk_), intent(in) :: imin,imax + integer(psb_ipk_), intent(out) :: nz + integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_ipk_), intent(in), optional :: iren(:) + integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + ! Local + integer(psb_ipk_), allocatable :: lia(:), lja(:) + + ! + ! Note: in principle we could use reallocate on assignment, + ! but GCC bug 52162 forces us to take defensive programming. + ! + if (allocated(ia)) then + call psb_realloc(size(ia),lia,info) + if (info == psb_success_) lia(:) = ia(:) + end if + if (allocated(ja)) then + call psb_realloc(size(ja),lja,info) + if (info == psb_success_) lja(:) = ja(:) + end if + + call a%csget(imin,imax,nz,lia,lja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + + call psb_ensure_size(size(lia),ia,info) + if (info == psb_success_) ia(:) = lia(:) + call psb_ensure_size(size(lja),ja,info) + if (info == psb_success_) ja(:) = lja(:) + + end subroutine psb_lz_icsgetrow +#endif + +end module psb_z_mat_mod diff --git a/base/modules/serial/psb_z_mat_mod.f90 b/base/modules/serial/psb_z_mat_mod.f90 deleted file mode 100644 index b86528eb4..000000000 --- a/base/modules/serial/psb_z_mat_mod.f90 +++ /dev/null @@ -1,1296 +0,0 @@ -! -! Parallel Sparse BLAS version 3.5 -! (C) Copyright 2006-2018 -! Salvatore Filippone -! Alfredo Buttari -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions -! are met: -! 1. Redistributions of source code must retain the above copyright -! notice, this list of conditions and the following disclaimer. -! 2. Redistributions in binary form must reproduce the above copyright -! notice, this list of conditions, and the following disclaimer in the -! documentation and/or other materials provided with the distribution. -! 3. The name of the PSBLAS group or the names of its contributors may -! not be used to endorse or promote products derived from this -! software without specific written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -! POSSIBILITY OF SUCH DAMAGE. -! -! -! -! package: psb_z_mat_mod -! -! This module contains the definition of the psb_z_sparse type which -! is a generic container for a sparse matrix and it is mostly meant to -! provide a mean of switching, at run-time, among different formats, -! potentially unknown at the library compile-time by adding a layer of -! indirection. This type encapsulates the psb_z_base_sparse_mat class -! inside another class which is the one visible to the user. -! Most methods of the psb_z_mat_mod simply call the methods of the -! encapsulated class. -! The exceptions are mainly cscnv and cp_from/cp_to; these provide -! the functionalities to have the encapsulated class change its -! type dynamically, and to extract/input an inner object. -! -! A sparse matrix has a state corresponding to its progression -! through the application life. -! In particular, computational methods can only be invoked when -! the matrix is in the ASSEMBLED state, whereas the other states are -! dedicated to operations on the internal matrix data. -! A sparse matrix can move between states according to the -! following state transition table. Associated with these states are -! the possible dynamic types of the inner matrix object. -! Only COO matrices can ever be in the BUILD state, whereas -! the ASSEMBLED and UPDATE state can be entered by any class. -! -! In Out Method -!| ---------------------------------- -!| Null Build csall -!| Build Build csput -!| Build Assembled cscnv -!| Assembled Assembled cscnv -!| Assembled Update reinit -!| Update Update csput -!| Update Assembled cscnv -!| * unchanged reall -!| Assembled Null free -! - - -module psb_z_mat_mod - - use psb_z_base_mat_mod - use psb_z_csr_mat_mod, only : psb_z_csr_sparse_mat - use psb_z_csc_mat_mod, only : psb_z_csc_sparse_mat - - type :: psb_zspmat_type - - class(psb_z_base_sparse_mat), allocatable :: a - - contains - ! Getters - procedure, pass(a) :: get_nrows => psb_z_get_nrows - procedure, pass(a) :: get_ncols => psb_z_get_ncols - procedure, pass(a) :: get_nzeros => psb_z_get_nzeros - procedure, pass(a) :: get_nz_row => psb_z_get_nz_row - procedure, pass(a) :: get_size => psb_z_get_size - procedure, pass(a) :: get_dupl => psb_z_get_dupl - procedure, pass(a) :: is_null => psb_z_is_null - procedure, pass(a) :: is_bld => psb_z_is_bld - procedure, pass(a) :: is_upd => psb_z_is_upd - procedure, pass(a) :: is_asb => psb_z_is_asb - procedure, pass(a) :: is_sorted => psb_z_is_sorted - procedure, pass(a) :: is_by_rows => psb_z_is_by_rows - procedure, pass(a) :: is_by_cols => psb_z_is_by_cols - procedure, pass(a) :: is_upper => psb_z_is_upper - procedure, pass(a) :: is_lower => psb_z_is_lower - procedure, pass(a) :: is_triangle => psb_z_is_triangle - procedure, pass(a) :: is_unit => psb_z_is_unit - procedure, pass(a) :: is_repeatable_updates => psb_z_is_repeatable_updates - procedure, pass(a) :: get_fmt => psb_z_get_fmt - procedure, pass(a) :: sizeof => psb_z_sizeof - - ! Setters - procedure, pass(a) :: set_nrows => psb_z_set_nrows - procedure, pass(a) :: set_ncols => psb_z_set_ncols - procedure, pass(a) :: set_dupl => psb_z_set_dupl - procedure, pass(a) :: set_null => psb_z_set_null - procedure, pass(a) :: set_bld => psb_z_set_bld - procedure, pass(a) :: set_upd => psb_z_set_upd - procedure, pass(a) :: set_asb => psb_z_set_asb - procedure, pass(a) :: set_sorted => psb_z_set_sorted - procedure, pass(a) :: set_upper => psb_z_set_upper - procedure, pass(a) :: set_lower => psb_z_set_lower - procedure, pass(a) :: set_triangle => psb_z_set_triangle - procedure, pass(a) :: set_unit => psb_z_set_unit - procedure, pass(a) :: set_repeatable_updates => psb_z_set_repeatable_updates - - ! Memory/data management - procedure, pass(a) :: csall => psb_z_csall - procedure, pass(a) :: free => psb_z_free - procedure, pass(a) :: trim => psb_z_trim - procedure, pass(a) :: csput_a => psb_z_csput_a - procedure, pass(a) :: csput_v => psb_z_csput_v - generic, public :: csput => csput_a, csput_v - procedure, pass(a) :: csgetptn => psb_z_csgetptn - procedure, pass(a) :: csgetrow => psb_z_csgetrow - procedure, pass(a) :: csgetblk => psb_z_csgetblk - generic, public :: csget => csgetptn, csgetrow, csgetblk - procedure, pass(a) :: tril => psb_z_tril - procedure, pass(a) :: triu => psb_z_triu - procedure, pass(a) :: m_csclip => psb_z_csclip - procedure, pass(a) :: b_csclip => psb_z_b_csclip - generic, public :: csclip => b_csclip, m_csclip - procedure, pass(a) :: clean_zeros => psb_z_clean_zeros - procedure, pass(a) :: reall => psb_z_reallocate_nz - procedure, pass(a) :: get_neigh => psb_z_get_neigh - procedure, pass(a) :: reinit => psb_z_reinit - procedure, pass(a) :: print_i => psb_z_sparse_print - procedure, pass(a) :: print_n => psb_z_n_sparse_print - generic, public :: print => print_i, print_n - procedure, pass(a) :: mold => psb_z_mold - procedure, pass(a) :: asb => psb_z_asb - procedure, pass(a) :: transp_1mat => psb_z_transp_1mat - procedure, pass(a) :: transp_2mat => psb_z_transp_2mat - generic, public :: transp => transp_1mat, transp_2mat - procedure, pass(a) :: transc_1mat => psb_z_transc_1mat - procedure, pass(a) :: transc_2mat => psb_z_transc_2mat - generic, public :: transc => transc_1mat, transc_2mat - - ! - ! Sync: centerpiece of handling of external storage. - ! Any derived class having extra storage upon sync - ! will guarantee that both fortran/host side and - ! external side contain the same data. The base - ! version is only a placeholder. - ! - procedure, pass(a) :: sync => z_mat_sync - procedure, pass(a) :: is_host => z_mat_is_host - procedure, pass(a) :: is_dev => z_mat_is_dev - procedure, pass(a) :: is_sync => z_mat_is_sync - procedure, pass(a) :: set_host => z_mat_set_host - procedure, pass(a) :: set_dev => z_mat_set_dev - procedure, pass(a) :: set_sync => z_mat_set_sync - - - ! These are specific to this level of encapsulation. - procedure, pass(a) :: mv_from_b => psb_z_mv_from - generic, public :: mv_from => mv_from_b - procedure, pass(a) :: mv_to_b => psb_z_mv_to - generic, public :: mv_to => mv_to_b - procedure, pass(a) :: cp_from_b => psb_z_cp_from - generic, public :: cp_from => cp_from_b - procedure, pass(a) :: cp_to_b => psb_z_cp_to - generic, public :: cp_to => cp_to_b - procedure, pass(a) :: clip_d_ip => psb_z_clip_d_ip - procedure, pass(a) :: clip_d => psb_z_clip_d - generic, public :: clip_diag => clip_d_ip, clip_d - procedure, pass(a) :: cscnv_np => psb_z_cscnv - procedure, pass(a) :: cscnv_ip => psb_z_cscnv_ip - procedure, pass(a) :: cscnv_base => psb_z_cscnv_base - generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base - procedure, pass(a) :: clone => psb_zspmat_clone - - ! Computational routines - procedure, pass(a) :: get_diag => psb_z_get_diag - procedure, pass(a) :: maxval => psb_z_maxval - procedure, pass(a) :: spnmi => psb_z_csnmi - procedure, pass(a) :: spnm1 => psb_z_csnm1 - procedure, pass(a) :: rowsum => psb_z_rowsum - procedure, pass(a) :: arwsum => psb_z_arwsum - procedure, pass(a) :: colsum => psb_z_colsum - procedure, pass(a) :: aclsum => psb_z_aclsum - procedure, pass(a) :: csmv_v => psb_z_csmv_vect - procedure, pass(a) :: csmv => psb_z_csmv - procedure, pass(a) :: csmm => psb_z_csmm - generic, public :: spmm => csmm, csmv, csmv_v - procedure, pass(a) :: scals => psb_z_scals - procedure, pass(a) :: scalv => psb_z_scal - generic, public :: scal => scals, scalv - procedure, pass(a) :: cssv_v => psb_z_cssv_vect - procedure, pass(a) :: cssv => psb_z_cssv - procedure, pass(a) :: cssm => psb_z_cssm - generic, public :: spsm => cssm, cssv, cssv_v - - end type psb_zspmat_type - - private :: psb_z_get_nrows, psb_z_get_ncols, & - & psb_z_get_nzeros, psb_z_get_size, & - & psb_z_get_dupl, psb_z_is_null, psb_z_is_bld, & - & psb_z_is_upd, psb_z_is_asb, psb_z_is_sorted, & - & psb_z_is_by_rows, psb_z_is_by_cols, psb_z_is_upper, & - & psb_z_is_lower, psb_z_is_triangle, psb_z_get_nz_row, & - & z_mat_sync, z_mat_is_host, z_mat_is_dev, & - & z_mat_is_sync, z_mat_set_host, z_mat_set_dev,& - & z_mat_set_sync - - - - class(psb_z_base_sparse_mat), allocatable, target, & - & save, private :: psb_z_base_mat_default - - interface psb_set_mat_default - module procedure psb_z_set_mat_default - end interface - - interface psb_get_mat_default - module procedure psb_z_get_mat_default - end interface - - interface psb_sizeof - module procedure psb_z_sizeof - end interface - - - ! == =================================== - ! - ! - ! - ! Setters - ! - ! - ! - ! - ! - ! - ! == =================================== - - - interface - subroutine psb_z_set_nrows(m,a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: m - end subroutine psb_z_set_nrows - end interface - - interface - subroutine psb_z_set_ncols(n,a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_z_set_ncols - end interface - - interface - subroutine psb_z_set_dupl(n,a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: n - end subroutine psb_z_set_dupl - end interface - - interface - subroutine psb_z_set_null(a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_set_null - end interface - - interface - subroutine psb_z_set_bld(a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_set_bld - end interface - - interface - subroutine psb_z_set_upd(a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_set_upd - end interface - - interface - subroutine psb_z_set_asb(a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_set_asb - end interface - - interface - subroutine psb_z_set_sorted(a,val) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_z_set_sorted - end interface - - interface - subroutine psb_z_set_triangle(a,val) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_z_set_triangle - end interface - - interface - subroutine psb_z_set_unit(a,val) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_z_set_unit - end interface - - interface - subroutine psb_z_set_lower(a,val) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_z_set_lower - end interface - - interface - subroutine psb_z_set_upper(a,val) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - end subroutine psb_z_set_upper - end interface - - interface - subroutine psb_z_sparse_print(iout,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_zspmat_type - integer(psb_ipk_), intent(in) :: iout - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_z_sparse_print - end interface - - interface - subroutine psb_z_n_sparse_print(fname,a,iv,head,ivr,ivc) - import :: psb_ipk_, psb_zspmat_type - character(len=*), intent(in) :: fname - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in), optional :: iv(:) - character(len=*), optional :: head - integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - end subroutine psb_z_n_sparse_print - end interface - - interface - subroutine psb_z_get_neigh(a,idx,neigh,n,info,lev) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: idx - integer(psb_ipk_), intent(out) :: n - integer(psb_ipk_), allocatable, intent(out) :: neigh(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: lev - end subroutine psb_z_get_neigh - end interface - - interface - subroutine psb_z_csall(nr,nc,a,info,nz) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nr,nc - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: nz - end subroutine psb_z_csall - end interface - - interface - subroutine psb_z_reallocate_nz(nz,a) - import :: psb_ipk_, psb_zspmat_type - integer(psb_ipk_), intent(in) :: nz - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_reallocate_nz - end interface - - interface - subroutine psb_z_free(a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_free - end interface - - interface - subroutine psb_z_trim(a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_trim - end interface - - interface - subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(inout) :: a - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_z_csput_a - end interface - - - interface - subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) - use psb_z_vect_mod, only : psb_z_vect_type - use psb_i_vect_mod, only : psb_i_vect_type - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - type(psb_z_vect_type), intent(inout) :: val - type(psb_i_vect_type), intent(inout) :: ia, ja - integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), intent(in), optional :: gtl(:) - end subroutine psb_z_csput_v - end interface - - interface - subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale - end subroutine psb_z_csgetptn - end interface - - interface - subroutine psb_z_csgetrow(imin,imax,a,nz,ia,ja,val,info,& - & jmin,jmax,iren,append,nzin,rscale,cscale,chksz) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_), intent(out) :: nz - integer(psb_ipk_), allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin - logical, intent(in), optional :: rscale,cscale,chksz - end subroutine psb_z_csgetrow - end interface - - interface - subroutine psb_z_csgetblk(imin,imax,a,b,info,& - & jmin,jmax,iren,append,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - class(psb_zspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(in) :: imin,imax - integer(psb_ipk_),intent(out) :: info - logical, intent(in), optional :: append - integer(psb_ipk_), intent(in), optional :: iren(:) - integer(psb_ipk_), intent(in), optional :: jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_z_csgetblk - end interface - - interface - subroutine psb_z_tril(a,l,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,u) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - class(psb_zspmat_type), intent(inout) :: l - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_zspmat_type), optional, intent(inout) :: u - end subroutine psb_z_tril - end interface - - interface - subroutine psb_z_triu(a,u,info,diag,imin,imax,& - & jmin,jmax,rscale,cscale,l) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - class(psb_zspmat_type), intent(inout) :: u - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: diag,imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - class(psb_zspmat_type), optional, intent(inout) :: l - end subroutine psb_z_triu - end interface - - - interface - subroutine psb_z_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - class(psb_zspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_z_csclip - end interface - - interface - subroutine psb_z_b_csclip(a,b,info,& - & imin,imax,jmin,jmax,rscale,cscale) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_coo_sparse_mat - class(psb_zspmat_type), intent(in) :: a - type(psb_z_coo_sparse_mat), intent(out) :: b - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - end subroutine psb_z_b_csclip - end interface - - interface - subroutine psb_z_mold(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(inout) :: a - class(psb_z_base_sparse_mat), allocatable, intent(out) :: b - end subroutine psb_z_mold - end interface - - interface - subroutine psb_z_asb(a,mold) - import :: psb_ipk_, psb_zspmat_type, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(inout) :: a - class(psb_z_base_sparse_mat), optional, intent(in) :: mold - end subroutine psb_z_asb - end interface - - interface - subroutine psb_z_transp_1mat(a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_transp_1mat - end interface - - interface - subroutine psb_z_transp_2mat(a,b) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(in) :: a - class(psb_zspmat_type), intent(inout) :: b - end subroutine psb_z_transp_2mat - end interface - - interface - subroutine psb_z_transc_1mat(a) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - end subroutine psb_z_transc_1mat - end interface - - interface - subroutine psb_z_transc_2mat(a,b) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(in) :: a - class(psb_zspmat_type), intent(inout) :: b - end subroutine psb_z_transc_2mat - end interface - - interface - subroutine psb_z_reinit(a,clear) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - logical, intent(in), optional :: clear - end subroutine psb_z_reinit - - end interface - - - ! - ! These methods are specific to the outer SPMAT_TYPE level, since - ! they tamper with the inner BASE_SPARSE_MAT object. - ! - ! - - ! - ! CSCNV: switches to a different internal derived type. - ! 3 versions: copying to target - ! copying to a base_sparse_mat object. - ! in place - ! - ! - interface - subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(in) :: a - class(psb_zspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psb_z_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_z_cscnv - end interface - - - interface - subroutine psb_z_cscnv_ip(a,iinfo,type,mold,dupl) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(out) :: iinfo - integer(psb_ipk_),optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psb_z_base_sparse_mat), intent(in), optional :: mold - end subroutine psb_z_cscnv_ip - end interface - - - interface - subroutine psb_z_cscnv_base(a,b,info,dupl) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out) :: b - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_),optional, intent(in) :: dupl - end subroutine psb_z_cscnv_base - end interface - - ! - ! Produce a version of the matrix with diagonal cut - ! out; passes through a COO buffer. - ! - interface - subroutine psb_z_clip_d(a,b,info) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(in) :: a - class(psb_zspmat_type), intent(inout) :: b - integer(psb_ipk_),intent(out) :: info - end subroutine psb_z_clip_d - end interface - - interface - subroutine psb_z_clip_d_ip(a,info) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info - end subroutine psb_z_clip_d_ip - end interface - - ! - ! These four interfaces cut through the - ! encapsulation between spmat_type and base_sparse_mat. - ! - interface - subroutine psb_z_mv_from(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - end subroutine psb_z_mv_from - end interface - - interface - subroutine psb_z_cp_from(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(out) :: a - class(psb_z_base_sparse_mat), intent(in) :: b - end subroutine psb_z_cp_from - end interface - - interface - subroutine psb_z_mv_to(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(inout) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - end subroutine psb_z_mv_to - end interface - - interface - subroutine psb_z_cp_to(a,b) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat - class(psb_zspmat_type), intent(in) :: a - class(psb_z_base_sparse_mat), intent(inout) :: b - end subroutine psb_z_cp_to - end interface - - ! - ! Transfer the internal allocation to the target. - ! - interface psb_move_alloc - subroutine psb_zspmat_type_move(a,b,info) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - class(psb_zspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_zspmat_type_move - end interface - - interface - subroutine psb_zspmat_clone(a,b,info) - import :: psb_ipk_, psb_zspmat_type - class(psb_zspmat_type), intent(inout) :: a - class(psb_zspmat_type), intent(inout) :: b - integer(psb_ipk_), intent(out) :: info - end subroutine psb_zspmat_clone - end interface - - - - - ! == =================================== - ! - ! - ! - ! Computational routines - ! - ! - ! - ! - ! - ! - ! == =================================== - - interface psb_csmm - subroutine psb_z_csmm(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_z_csmm - subroutine psb_z_csmv(alpha,a,x,beta,y,info,trans) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_z_csmv - subroutine psb_z_csmv_vect(alpha,a,x,beta,y,info,trans) - use psb_z_vect_mod, only : psb_z_vect_type - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_z_vect_type), intent(inout) :: x - type(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans - end subroutine psb_z_csmv_vect - end interface - - interface psb_cssm - subroutine psb_z_cssm(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) - complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_z_cssm - subroutine psb_z_cssv(alpha,a,x,beta,y,info,trans,scale,d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta, x(:) - complex(psb_dpk_), intent(inout) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - complex(psb_dpk_), intent(in), optional :: d(:) - end subroutine psb_z_cssv - subroutine psb_z_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d) - use psb_z_vect_mod, only : psb_z_vect_type - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(in) :: alpha, beta - type(psb_z_vect_type), intent(inout) :: x - type(psb_z_vect_type), intent(inout) :: y - integer(psb_ipk_), intent(out) :: info - character, optional, intent(in) :: trans, scale - type(psb_z_vect_type), optional, intent(inout) :: d - end subroutine psb_z_cssv_vect - end interface - - interface - function psb_z_maxval(a) result(res) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_z_maxval - end interface - - interface - function psb_z_csnmi(a) result(res) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_z_csnmi - end interface - - interface - function psb_z_csnm1(a) result(res) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - real(psb_dpk_) :: res - end function psb_z_csnm1 - end interface - - interface - function psb_z_rowsum(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_z_rowsum - end interface - - interface - function psb_z_arwsum(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_z_arwsum - end interface - - interface - function psb_z_colsum(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_z_colsum - end interface - - interface - function psb_z_aclsum(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - real(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_z_aclsum - end interface - - interface - function psb_z_get_diag(a,info) result(d) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), allocatable :: d(:) - integer(psb_ipk_), intent(out) :: info - end function psb_z_get_diag - end interface - - interface psb_scal - subroutine psb_z_scal(d,a,info,side) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: side - end subroutine psb_z_scal - subroutine psb_z_scals(d,a,info) - import :: psb_ipk_, psb_zspmat_type, psb_dpk_ - class(psb_zspmat_type), intent(inout) :: a - complex(psb_dpk_), intent(in) :: d - integer(psb_ipk_), intent(out) :: info - end subroutine psb_z_scals - end interface - - -contains - - - - subroutine psb_z_set_mat_default(a) - implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - - if (allocated(psb_z_base_mat_default)) then - deallocate(psb_z_base_mat_default) - end if - allocate(psb_z_base_mat_default, mold=a) - - end subroutine psb_z_set_mat_default - - function psb_z_get_mat_default(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - class(psb_z_base_sparse_mat), pointer :: res - - res => psb_z_get_base_mat_default() - - end function psb_z_get_mat_default - - - function psb_z_get_base_mat_default() result(res) - implicit none - class(psb_z_base_sparse_mat), pointer :: res - - if (.not.allocated(psb_z_base_mat_default)) then - allocate(psb_z_csr_sparse_mat :: psb_z_base_mat_default) - end if - - res => psb_z_base_mat_default - - end function psb_z_get_base_mat_default - - - - - ! == =================================== - ! - ! - ! - ! Getters - ! - ! - ! - ! - ! - ! == =================================== - - - function psb_z_sizeof(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - integer(psb_long_int_k_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%sizeof() - end if - - end function psb_z_sizeof - - - function psb_z_get_fmt(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - character(len=5) :: res - - if (allocated(a%a)) then - res = a%a%get_fmt() - else - res = 'NULL' - end if - - end function psb_z_get_fmt - - - function psb_z_get_dupl(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_dupl() - else - res = psb_invalid_ - end if - end function psb_z_get_dupl - - function psb_z_get_nrows(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_nrows() - else - res = 0 - end if - - end function psb_z_get_nrows - - function psb_z_get_ncols(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - if (allocated(a%a)) then - res = a%a%get_ncols() - else - res = 0 - end if - - end function psb_z_get_ncols - - function psb_z_is_triangle(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_triangle() - else - res = .false. - end if - - end function psb_z_is_triangle - - function psb_z_is_unit(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_unit() - else - res = .false. - end if - - end function psb_z_is_unit - - function psb_z_is_upper(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upper() - else - res = .false. - end if - - end function psb_z_is_upper - - function psb_z_is_lower(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = .not. a%a%is_upper() - else - res = .false. - end if - - end function psb_z_is_lower - - function psb_z_is_null(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_null() - else - res = .true. - end if - - end function psb_z_is_null - - function psb_z_is_bld(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_bld() - else - res = .false. - end if - - end function psb_z_is_bld - - function psb_z_is_upd(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_upd() - else - res = .false. - end if - - end function psb_z_is_upd - - function psb_z_is_asb(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_asb() - else - res = .false. - end if - - end function psb_z_is_asb - - function psb_z_is_sorted(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_sorted() - else - res = .false. - end if - - end function psb_z_is_sorted - - function psb_z_is_by_rows(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_rows() - else - res = .false. - end if - - end function psb_z_is_by_rows - - function psb_z_is_by_cols(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_by_cols() - else - res = .false. - end if - - end function psb_z_is_by_cols - - - ! - subroutine z_mat_sync(a) - implicit none - class(psb_zspmat_type), target, intent(in) :: a - - if (allocated(a%a)) call a%a%sync() - - end subroutine z_mat_sync - - ! - subroutine z_mat_set_host(a) - implicit none - class(psb_zspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_host() - - end subroutine z_mat_set_host - - - ! - subroutine z_mat_set_dev(a) - implicit none - class(psb_zspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_dev() - - end subroutine z_mat_set_dev - - ! - subroutine z_mat_set_sync(a) - implicit none - class(psb_zspmat_type), intent(inout) :: a - - if (allocated(a%a)) call a%a%set_sync() - - end subroutine z_mat_set_sync - - ! - function z_mat_is_dev(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_dev() - else - res = .false. - end if - end function z_mat_is_dev - - ! - function z_mat_is_host(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_host() - else - res = .true. - end if - end function z_mat_is_host - - ! - function z_mat_is_sync(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - - if (allocated(a%a)) then - res = a%a%is_sync() - else - res = .true. - end if - - end function z_mat_is_sync - - - function psb_z_is_repeatable_updates(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - logical :: res - - if (allocated(a%a)) then - res = a%a%is_repeatable_updates() - else - res = .false. - end if - - end function psb_z_is_repeatable_updates - - subroutine psb_z_set_repeatable_updates(a,val) - implicit none - class(psb_zspmat_type), intent(inout) :: a - logical, intent(in), optional :: val - - if (allocated(a%a)) then - call a%a%set_repeatable_updates(val) - end if - - end subroutine psb_z_set_repeatable_updates - - - function psb_z_get_nzeros(a) result(res) - implicit none - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - if (allocated(a%a)) then - res = a%a%get_nzeros() - end if - - end function psb_z_get_nzeros - - function psb_z_get_size(a) result(res) - - implicit none - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - - res = 0 - if (allocated(a%a)) then - res = a%a%get_size() - end if - - end function psb_z_get_size - - - function psb_z_get_nz_row(idx,a) result(res) - implicit none - integer(psb_ipk_), intent(in) :: idx - class(psb_zspmat_type), intent(in) :: a - integer(psb_ipk_) :: res - - res = 0 - - if (allocated(a%a)) res = a%a%get_nz_row(idx) - - end function psb_z_get_nz_row - - subroutine psb_z_clean_zeros(a,info) - implicit none - integer(psb_ipk_), intent(out) :: info - class(psb_zspmat_type), intent(inout) :: a - - info = 0 - if (allocated(a%a)) call a%a%clean_zeros(info) - - end subroutine psb_z_clean_zeros - - -end module psb_z_mat_mod diff --git a/base/modules/serial/psb_z_serial_mod.f90 b/base/modules/serial/psb_z_serial_mod.f90 index fdefb0a82..5afbcf961 100644 --- a/base/modules/serial/psb_z_serial_mod.f90 +++ b/base/modules/serial/psb_z_serial_mod.f90 @@ -119,9 +119,9 @@ module psb_z_serial_mod use psb_z_mat_mod, only : psb_zspmat_type import :: psb_ipk_ implicit none - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr type(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info type(psb_zspmat_type), intent(in), optional :: b logical,intent(in), optional :: rowscale end subroutine psb_zrwextd @@ -129,12 +129,32 @@ module psb_z_serial_mod use psb_z_mat_mod, only : psb_z_base_sparse_mat import :: psb_ipk_ implicit none - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr class(psb_z_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: b logical,intent(in), optional :: rowscale end subroutine psb_zbase_rwextd + subroutine psb_lzrwextd(nr,a,info,b,rowscale) + use psb_z_mat_mod, only : psb_lzspmat_type + import :: psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: nr + type(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + type(psb_lzspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + end subroutine psb_lzrwextd + subroutine psb_lzbase_rwextd(nr,a,info,b,rowscale) + use psb_z_mat_mod, only : psb_lz_base_sparse_mat + import :: psb_ipk_, psb_lpk_ + implicit none + integer(psb_lpk_), intent(in) :: nr + class(psb_lz_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + class(psb_lz_base_sparse_mat), intent(in), optional :: b + logical,intent(in), optional :: rowscale + end subroutine psb_lzbase_rwextd end interface psb_rwextd @@ -203,6 +223,69 @@ module psb_z_serial_mod end subroutine psb_z_aspxpby end interface psb_aspxpby + interface psb_spspmm + subroutine psb_lzspspmm(a,b,c,info) + use psb_z_mat_mod, only : psb_lzspmat_type + import :: psb_ipk_ + implicit none + type(psb_lzspmat_type), intent(in) :: a,b + type(psb_lzspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzspspmm + subroutine psb_lzcsrspspmm(a,b,c,info) + use psb_z_mat_mod, only : psb_lz_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzcsrspspmm + subroutine psb_lzcscspspmm(a,b,c,info) + use psb_z_mat_mod, only : psb_lz_csc_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a,b + type(psb_lz_csc_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzcscspspmm + end interface psb_spspmm + + interface psb_symbmm + subroutine psb_lzsymbmm(a,b,c,info) + use psb_z_mat_mod, only : psb_lzspmat_type + import :: psb_ipk_ + implicit none + type(psb_lzspmat_type), intent(in) :: a,b + type(psb_lzspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzsymbmm + subroutine psb_lzbase_symbmm(a,b,c,info) + use psb_z_mat_mod, only : psb_lz_base_sparse_mat, psb_lz_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lzbase_symbmm + end interface psb_symbmm + + interface psb_numbmm + subroutine psb_lznumbmm(a,b,c) + use psb_z_mat_mod, only : psb_lzspmat_type + import :: psb_ipk_ + implicit none + type(psb_lzspmat_type), intent(in) :: a,b + type(psb_lzspmat_type), intent(inout) :: c + end subroutine psb_lznumbmm + subroutine psb_lzbase_numbmm(a,b,c) + use psb_z_mat_mod, only : psb_lz_base_sparse_mat, psb_lz_csr_sparse_mat + import :: psb_ipk_ + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(inout) :: c + end subroutine psb_lzbase_numbmm + end interface psb_numbmm + contains subroutine psb_zcsprt(iout,a,iv,head,ivr,ivc) diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 00746540b..f6da1ded4 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -62,8 +62,9 @@ module psb_z_vect_mod procedure, pass(x) :: ins_v => z_vect_ins_v generic, public :: ins => ins_v, ins_a procedure, pass(x) :: bld_x => z_vect_bld_x - procedure, pass(x) :: bld_n => z_vect_bld_n - generic, public :: bld => bld_x, bld_n + procedure, pass(x) :: bld_mn => z_vect_bld_mn + procedure, pass(x) :: bld_en => z_vect_bld_en + generic, public :: bld => bld_x, bld_mn, bld_en procedure, pass(x) :: get_vect => z_vect_get_vect procedure, pass(x) :: cnv => z_vect_cnv procedure, pass(x) :: set_scal => z_vect_set_scal @@ -112,7 +113,8 @@ module psb_z_vect_mod & z_vect_all, z_vect_reall, z_vect_zero, z_vect_asb, & & z_vect_gthab, z_vect_gthzv, z_vect_sctb, & & z_vect_free, z_vect_ins_a, z_vect_ins_v, z_vect_bld_x, & - & z_vect_bld_n, z_vect_get_vect, z_vect_cnv, z_vect_set_scal, & + & z_vect_bld_mn, z_vect_bld_en, z_vect_get_vect, & + & z_vect_cnv, z_vect_set_scal, & & z_vect_set_vect, z_vect_clone, z_vect_sync, z_vect_is_host, & & z_vect_is_dev, z_vect_is_sync, z_vect_set_host, & & z_vect_set_dev, z_vect_set_sync @@ -207,8 +209,8 @@ contains end subroutine z_vect_bld_x - subroutine z_vect_bld_n(x,n,mold) - integer(psb_ipk_), intent(in) :: n + subroutine z_vect_bld_mn(x,n,mold) + integer(psb_mpk_), intent(in) :: n class(psb_z_vect_type), intent(inout) :: x class(psb_z_base_vect_type), intent(in), optional :: mold integer(psb_ipk_) :: info @@ -225,7 +227,28 @@ contains endif if (info == psb_success_) call x%v%bld(n) - end subroutine z_vect_bld_n + end subroutine z_vect_bld_mn + + + subroutine z_vect_bld_en(x,n,mold) + integer(psb_epk_), intent(in) :: n + class(psb_z_vect_type), intent(inout) :: x + class(psb_z_base_vect_type), intent(in), optional :: mold + integer(psb_ipk_) :: info + + info = psb_success_ + + if (allocated(x%v)) & + & call x%free(info) + + if (present(mold)) then + allocate(x%v,stat=info,mold=mold) + else + allocate(x%v,stat=info, mold=psb_z_get_base_vect_default()) + endif + if (info == psb_success_) call x%v%bld(n) + + end subroutine z_vect_bld_en function z_vect_get_vect(x,n) result(res) class(psb_z_vect_type), intent(inout) :: x @@ -291,7 +314,7 @@ contains function z_vect_sizeof(x) result(res) implicit none class(psb_z_vect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function z_vect_sizeof @@ -1014,7 +1037,7 @@ contains function z_vect_sizeof(x) result(res) implicit none class(psb_z_multivect_type), intent(in) :: x - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 if (allocated(x%v)) res = x%v%sizeof() end function z_vect_sizeof diff --git a/base/modules/tools/psb_c_tools_a_mod.f90 b/base/modules/tools/psb_c_tools_a_mod.f90 new file mode 100644 index 000000000..6c864eadf --- /dev/null +++ b/base/modules/tools/psb_c_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +Module psb_c_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_calloc(x, desc_a, info, n, lb) + import + implicit none + complex(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_calloc + subroutine psb_callocv(x, desc_a,info,n) + import + implicit none + complex(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_callocv + end interface + + + interface psb_geasb + subroutine psb_casb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_casb + subroutine psb_casbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_casbv + end interface + + interface psb_gefree + subroutine psb_cfree(x, desc_a, info) + import + implicit none + complex(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cfree + subroutine psb_cfreev(x, desc_a, info) + import + implicit none + complex(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cfreev + end interface + + + interface psb_geins + subroutine psb_cinsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_),intent(inout) :: x(:,:) + integer(psb_lpk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_cinsi + subroutine psb_cinsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_),intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_cinsvi + end interface + +end module psb_c_tools_a_mod diff --git a/base/modules/tools/psb_c_tools_mod.f90 b/base/modules/tools/psb_c_tools_mod.f90 index cda6b1a3a..7257f5921 100644 --- a/base/modules/tools/psb_c_tools_mod.f90 +++ b/base/modules/tools/psb_c_tools_mod.f90 @@ -30,28 +30,13 @@ ! ! Module psb_c_tools_mod - use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_ - use psb_c_vect_mod, only : psb_c_base_vect_type, psb_c_vect_type, psb_i_vect_type - use psb_c_mat_mod, only : psb_cspmat_type, psb_c_base_sparse_mat + use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_ + use psb_c_vect_mod, only : psb_c_base_vect_type, psb_c_vect_type + use psb_c_mat_mod, only : psb_cspmat_type, psb_lcspmat_type, psb_c_base_sparse_mat + use psb_l_vect_mod, only : psb_l_vect_type use psb_c_multivect_mod, only : psb_c_base_multivect_type, psb_c_multivect_type interface psb_geall - subroutine psb_calloc(x, desc_a, info, n, lb) - import - implicit none - complex(psb_spk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_calloc - subroutine psb_callocv(x, desc_a,info,n) - import - implicit none - complex(psb_spk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_callocv subroutine psb_calloc_vect(x, desc_a,info,n) import implicit none @@ -80,22 +65,6 @@ Module psb_c_tools_mod interface psb_geasb - subroutine psb_casb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_casb - subroutine psb_casbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_casbv subroutine psb_casb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -127,20 +96,6 @@ Module psb_c_tools_mod end interface interface psb_gefree - subroutine psb_cfree(x, desc_a, info) - import - implicit none - complex(psb_spk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_cfree - subroutine psb_cfreev(x, desc_a, info) - import - implicit none - complex(psb_spk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_cfreev subroutine psb_cfree_vect(x, desc_a, info) import implicit none @@ -166,37 +121,13 @@ Module psb_c_tools_mod interface psb_geins - subroutine psb_cinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_cinsi - subroutine psb_cinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_cinsvi subroutine psb_cins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_c_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -208,7 +139,7 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_c_vect_type), intent(inout) :: x - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_c_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -220,7 +151,7 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_c_vect_type), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -232,7 +163,7 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_c_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -266,6 +197,18 @@ Module psb_c_tools_mod character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_csphalo + Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + import + implicit none + Type(psb_lcspmat_type),Intent(in) :: a + Type(psb_lcspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer(psb_ipk_), intent(in), optional :: data + end Subroutine psb_lcsphalo end interface @@ -310,9 +253,10 @@ Module psb_c_tools_mod implicit none type(psb_desc_type), intent(inout) :: desc_a type(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild logical, intent(in), optional :: local end subroutine psb_cspins @@ -323,7 +267,7 @@ Module psb_c_tools_mod type(psb_desc_type), intent(inout) :: desc_a type(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz - type(psb_i_vect_type), intent(inout) :: ia,ja + type(psb_l_vect_type), intent(inout) :: ia,ja type(psb_c_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild @@ -335,9 +279,10 @@ Module psb_c_tools_mod type(psb_desc_type), intent(in) :: desc_ar type(psb_desc_type), intent(inout) :: desc_ac type(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_cspins_2desc end interface diff --git a/base/modules/tools/psb_cd_tools_mod.f90 b/base/modules/tools/psb_cd_tools_mod.f90 index 5db8ac06e..3445e950d 100644 --- a/base/modules/tools/psb_cd_tools_mod.f90 +++ b/base/modules/tools/psb_cd_tools_mod.f90 @@ -93,16 +93,18 @@ module psb_cd_tools_mod interface psb_cdins subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) - import :: psb_ipk_, psb_desc_type + import :: psb_ipk_, psb_lpk_, psb_desc_type type(psb_desc_type), intent(inout) :: desc_a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(out) :: ila(:), jla(:) end subroutine psb_cdinsrc subroutine psb_cdinsc(nz,ja,desc,info,jla,mask,lidx) - import :: psb_ipk_, psb_desc_type + import :: psb_ipk_, psb_lpk_, psb_desc_type type(psb_desc_type), intent(inout) :: desc - integer(psb_ipk_), intent(in) :: nz,ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ja(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(out) :: jla(:) logical, optional, target, intent(in) :: mask(:) @@ -112,10 +114,10 @@ module psb_cd_tools_mod interface psb_cdbldext Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) - import :: psb_ipk_, psb_desc_type + import :: psb_ipk_, psb_lpk_, psb_desc_type Implicit None Type(psb_desc_type), Intent(inout), target :: desc_a - integer(psb_ipk_), intent(in) :: in_list(:) + integer(psb_lpk_), intent(in) :: in_list(:) Type(psb_desc_type), Intent(out) :: desc_ov integer(psb_ipk_), intent(out) :: info logical, intent(in), optional, target :: mask(:) @@ -158,10 +160,11 @@ module psb_cd_tools_mod subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl,& & globalcheck,lidx) - import :: psb_ipk_, psb_desc_type, psb_parts + import :: psb_ipk_, psb_lpk_, psb_desc_type, psb_parts implicit None procedure(psb_parts) :: parts - integer(psb_ipk_), intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl,lidx(:) + integer(psb_lpk_), intent(in) :: mg,ng, vl(:) + integer(psb_ipk_), intent(in) :: ictxt, vg(:), lidx(:),nl integer(psb_ipk_), intent(in) :: flag logical, intent(in) :: repl, globalcheck integer(psb_ipk_), intent(out) :: info @@ -188,6 +191,103 @@ module psb_cd_tools_mod end subroutine psb_cd_switch_ovl_indxmap end interface + + interface psb_glob_to_loc + subroutine psb_glob_to_loc2v(x,y,desc_a,info,iact,owned) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_lpk_),intent(in) :: x(:) + integer(psb_ipk_),intent(out) :: y(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: owned + character, intent(in), optional :: iact + end subroutine psb_glob_to_loc2v + subroutine psb_glob_to_loc1v(x,desc_a,info,iact,owned) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_lpk_),intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: owned + character, intent(in), optional :: iact + end subroutine psb_glob_to_loc1v + subroutine psb_glob_to_loc2s(x,y,desc_a,info,iact,owned) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_lpk_),intent(in) :: x + integer(psb_ipk_),intent(out) :: y + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: iact + logical, intent(in), optional :: owned + end subroutine psb_glob_to_loc2s + subroutine psb_glob_to_loc1s(x,desc_a,info,iact,owned) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_lpk_),intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: iact + logical, intent(in), optional :: owned + end subroutine psb_glob_to_loc1s + end interface + + interface psb_loc_to_glob + subroutine psb_loc_to_glob2v(x,y,desc_a,info,iact) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(in) :: x(:) + integer(psb_lpk_),intent(out) :: y(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: iact + end subroutine psb_loc_to_glob2v + subroutine psb_loc_to_glob1v(x,desc_a,info,iact) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_lpk_),intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: iact + end subroutine psb_loc_to_glob1v + subroutine psb_loc_to_glob2s(x,y,desc_a,info,iact) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(in) :: x + integer(psb_lpk_),intent(out) :: y + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: iact + end subroutine psb_loc_to_glob2s + subroutine psb_loc_to_glob1s(x,desc_a,info,iact) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_lpk_),intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: iact + end subroutine psb_loc_to_glob1s + + end interface + + + interface psb_is_owned + module procedure psb_is_owned + end interface + + interface psb_is_local + module procedure psb_is_local + end interface + + interface psb_owned_index + module procedure psb_owned_index, psb_owned_index_v + end interface + + interface psb_local_index + module procedure psb_local_index, psb_local_index_v + end interface + contains subroutine psb_get_boundary(bndel,desc,info) @@ -209,6 +309,93 @@ contains call psb_icdasb(desc,info,ext_hv=.false.,mold=mold) end subroutine psb_cdasb + + + function psb_is_owned(idx,desc) + implicit none + integer(psb_lpk_), intent(in) :: idx + type(psb_desc_type), intent(in) :: desc + logical :: psb_is_owned + logical :: res + integer(psb_ipk_) :: info + + call psb_owned_index(res,idx,desc,info) + if (info /= psb_success_) res=.false. + psb_is_owned = res + end function psb_is_owned + + function psb_is_local(idx,desc) + implicit none + integer(psb_lpk_), intent(in) :: idx + type(psb_desc_type), intent(in) :: desc + logical :: psb_is_local + logical :: res + integer(psb_ipk_) :: info + + call psb_local_index(res,idx,desc,info) + if (info /= psb_success_) res=.false. + psb_is_local = res + end function psb_is_local + + subroutine psb_owned_index(res,idx,desc,info) + implicit none + integer(psb_lpk_), intent(in) :: idx + type(psb_desc_type), intent(in) :: desc + logical, intent(out) :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: lx + + call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.true.) + + res = (lx>0) + end subroutine psb_owned_index + + subroutine psb_owned_index_v(res,idx,desc,info) + implicit none + integer(psb_lpk_), intent(in) :: idx(:) + type(psb_desc_type), intent(in) :: desc + logical, intent(out) :: res(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), allocatable :: lx(:) + + allocate(lx(size(idx)),stat=info) + res=.false. + if (info /= psb_success_) return + call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.true.) + + res = (lx>0) + end subroutine psb_owned_index_v + + subroutine psb_local_index(res,idx,desc,info) + implicit none + integer(psb_lpk_), intent(in) :: idx + type(psb_desc_type), intent(in) :: desc + logical, intent(out) :: res + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: lx + + call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.false.) + + res = (lx>0) + end subroutine psb_local_index + + subroutine psb_local_index_v(res,idx,desc,info) + implicit none + integer(psb_lpk_), intent(in) :: idx(:) + type(psb_desc_type), intent(in) :: desc + logical, intent(out) :: res(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), allocatable :: lx(:) + + allocate(lx(size(idx)),stat=info) + res=.false. + if (info /= psb_success_) return + call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.false.) + + res = (lx>0) + end subroutine psb_local_index_v end module psb_cd_tools_mod diff --git a/base/modules/tools/psb_d_tools_a_mod.f90 b/base/modules/tools/psb_d_tools_a_mod.f90 new file mode 100644 index 000000000..1ce3d7749 --- /dev/null +++ b/base/modules/tools/psb_d_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +Module psb_d_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_dalloc(x, desc_a, info, n, lb) + import + implicit none + real(psb_dpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_dalloc + subroutine psb_dallocv(x, desc_a,info,n) + import + implicit none + real(psb_dpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_dallocv + end interface + + + interface psb_geasb + subroutine psb_dasb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_dasb + subroutine psb_dasbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_dasbv + end interface + + interface psb_gefree + subroutine psb_dfree(x, desc_a, info) + import + implicit none + real(psb_dpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dfree + subroutine psb_dfreev(x, desc_a, info) + import + implicit none + real(psb_dpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dfreev + end interface + + + interface psb_geins + subroutine psb_dinsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_),intent(inout) :: x(:,:) + integer(psb_lpk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_dinsi + subroutine psb_dinsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_),intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_dinsvi + end interface + +end module psb_d_tools_a_mod diff --git a/base/modules/tools/psb_d_tools_mod.f90 b/base/modules/tools/psb_d_tools_mod.f90 index 95c2314c0..624a7e078 100644 --- a/base/modules/tools/psb_d_tools_mod.f90 +++ b/base/modules/tools/psb_d_tools_mod.f90 @@ -30,28 +30,13 @@ ! ! Module psb_d_tools_mod - use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_ - use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type, psb_i_vect_type - use psb_d_mat_mod, only : psb_dspmat_type, psb_d_base_sparse_mat + use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_ + use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type + use psb_d_mat_mod, only : psb_dspmat_type, psb_ldspmat_type, psb_d_base_sparse_mat + use psb_l_vect_mod, only : psb_l_vect_type use psb_d_multivect_mod, only : psb_d_base_multivect_type, psb_d_multivect_type interface psb_geall - subroutine psb_dalloc(x, desc_a, info, n, lb) - import - implicit none - real(psb_dpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_dalloc - subroutine psb_dallocv(x, desc_a,info,n) - import - implicit none - real(psb_dpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_dallocv subroutine psb_dalloc_vect(x, desc_a,info,n) import implicit none @@ -80,22 +65,6 @@ Module psb_d_tools_mod interface psb_geasb - subroutine psb_dasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_dasb - subroutine psb_dasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_dasbv subroutine psb_dasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -127,20 +96,6 @@ Module psb_d_tools_mod end interface interface psb_gefree - subroutine psb_dfree(x, desc_a, info) - import - implicit none - real(psb_dpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_dfree - subroutine psb_dfreev(x, desc_a, info) - import - implicit none - real(psb_dpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_dfreev subroutine psb_dfree_vect(x, desc_a, info) import implicit none @@ -166,37 +121,13 @@ Module psb_d_tools_mod interface psb_geins - subroutine psb_dinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_dinsi - subroutine psb_dinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_dinsvi subroutine psb_dins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_d_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -208,7 +139,7 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_d_vect_type), intent(inout) :: x - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_d_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -220,7 +151,7 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_d_vect_type), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -232,7 +163,7 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_d_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -266,6 +197,18 @@ Module psb_d_tools_mod character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_dsphalo + Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + import + implicit none + Type(psb_ldspmat_type),Intent(in) :: a + Type(psb_ldspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer(psb_ipk_), intent(in), optional :: data + end Subroutine psb_ldsphalo end interface @@ -310,9 +253,10 @@ Module psb_d_tools_mod implicit none type(psb_desc_type), intent(inout) :: desc_a type(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild logical, intent(in), optional :: local end subroutine psb_dspins @@ -323,7 +267,7 @@ Module psb_d_tools_mod type(psb_desc_type), intent(inout) :: desc_a type(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz - type(psb_i_vect_type), intent(inout) :: ia,ja + type(psb_l_vect_type), intent(inout) :: ia,ja type(psb_d_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild @@ -335,9 +279,10 @@ Module psb_d_tools_mod type(psb_desc_type), intent(in) :: desc_ar type(psb_desc_type), intent(inout) :: desc_ac type(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_dspins_2desc end interface diff --git a/base/modules/tools/psb_e_tools_a_mod.f90 b/base/modules/tools/psb_e_tools_a_mod.f90 new file mode 100644 index 000000000..bce8cb404 --- /dev/null +++ b/base/modules/tools/psb_e_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +Module psb_e_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_epk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_ealloc(x, desc_a, info, n, lb) + import + implicit none + integer(psb_epk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_ealloc + subroutine psb_eallocv(x, desc_a,info,n) + import + implicit none + integer(psb_epk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_eallocv + end interface + + + interface psb_geasb + subroutine psb_easb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_easb + subroutine psb_easbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_easbv + end interface + + interface psb_gefree + subroutine psb_efree(x, desc_a, info) + import + implicit none + integer(psb_epk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_efree + subroutine psb_efreev(x, desc_a, info) + import + implicit none + integer(psb_epk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_efreev + end interface + + + interface psb_geins + subroutine psb_einsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_),intent(inout) :: x(:,:) + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_epk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_einsi + subroutine psb_einsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_),intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_epk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_einsvi + end interface + +end module psb_e_tools_a_mod diff --git a/base/modules/tools/psb_i_tools_mod.f90 b/base/modules/tools/psb_i_tools_mod.f90 index 9fc587bdd..8378dcfbe 100644 --- a/base/modules/tools/psb_i_tools_mod.f90 +++ b/base/modules/tools/psb_i_tools_mod.f90 @@ -30,27 +30,12 @@ ! ! Module psb_i_tools_mod - use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_success_ + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_success_ use psb_i_vect_mod, only : psb_i_base_vect_type, psb_i_vect_type + use psb_l_vect_mod, only : psb_l_vect_type use psb_i_multivect_mod, only : psb_i_base_multivect_type, psb_i_multivect_type interface psb_geall - subroutine psb_ialloc(x, desc_a, info, n, lb) - import - implicit none - integer(psb_ipk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_ialloc - subroutine psb_iallocv(x, desc_a,info,n) - import - implicit none - integer(psb_ipk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_iallocv subroutine psb_ialloc_vect(x, desc_a,info,n) import implicit none @@ -79,22 +64,6 @@ Module psb_i_tools_mod interface psb_geasb - subroutine psb_iasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_iasb - subroutine psb_iasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_iasbv subroutine psb_iasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -126,20 +95,6 @@ Module psb_i_tools_mod end interface interface psb_gefree - subroutine psb_ifree(x, desc_a, info) - import - implicit none - integer(psb_ipk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ifree - subroutine psb_ifreev(x, desc_a, info) - import - implicit none - integer(psb_ipk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_ifreev subroutine psb_ifree_vect(x, desc_a, info) import implicit none @@ -165,37 +120,13 @@ Module psb_i_tools_mod interface psb_geins - subroutine psb_iinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_ipk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_iinsi - subroutine psb_iinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_ipk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_iinsvi subroutine psb_iins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_i_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) integer(psb_ipk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -207,7 +138,7 @@ Module psb_i_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_i_vect_type), intent(inout) :: x - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_i_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -219,7 +150,7 @@ Module psb_i_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_i_vect_type), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) integer(psb_ipk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -231,7 +162,7 @@ Module psb_i_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_i_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) integer(psb_ipk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -240,188 +171,4 @@ Module psb_i_tools_mod end interface - interface psb_glob_to_loc - subroutine psb_glob_to_loc2v(x,y,desc_a,info,iact,owned) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(in) :: x(:) - integer(psb_ipk_),intent(out) :: y(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: owned - character, intent(in), optional :: iact - end subroutine psb_glob_to_loc2v - subroutine psb_glob_to_loc1v(x,desc_a,info,iact,owned) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: owned - character, intent(in), optional :: iact - end subroutine psb_glob_to_loc1v - subroutine psb_glob_to_loc2s(x,y,desc_a,info,iact,owned) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(in) :: x - integer(psb_ipk_),intent(out) :: y - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: iact - logical, intent(in), optional :: owned - end subroutine psb_glob_to_loc2s - subroutine psb_glob_to_loc1s(x,desc_a,info,iact,owned) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: iact - logical, intent(in), optional :: owned - end subroutine psb_glob_to_loc1s - end interface - - interface psb_loc_to_glob - subroutine psb_loc_to_glob2v(x,y,desc_a,info,iact) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(in) :: x(:) - integer(psb_ipk_),intent(out) :: y(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: iact - end subroutine psb_loc_to_glob2v - subroutine psb_loc_to_glob1v(x,desc_a,info,iact) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: iact - end subroutine psb_loc_to_glob1v - subroutine psb_loc_to_glob2s(x,y,desc_a,info,iact) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(in) :: x - integer(psb_ipk_),intent(out) :: y - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: iact - end subroutine psb_loc_to_glob2s - subroutine psb_loc_to_glob1s(x,desc_a,info,iact) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x - integer(psb_ipk_), intent(out) :: info - character, intent(in), optional :: iact - end subroutine psb_loc_to_glob1s - - end interface - - - interface psb_is_owned - module procedure psb_is_owned - end interface - - interface psb_is_local - module procedure psb_is_local - end interface - - interface psb_owned_index - module procedure psb_owned_index, psb_owned_index_v - end interface - - interface psb_local_index - module procedure psb_local_index, psb_local_index_v - end interface - -contains - - function psb_is_owned(idx,desc) - implicit none - integer(psb_ipk_), intent(in) :: idx - type(psb_desc_type), intent(in) :: desc - logical :: psb_is_owned - logical :: res - integer(psb_ipk_) :: info - - call psb_owned_index(res,idx,desc,info) - if (info /= psb_success_) res=.false. - psb_is_owned = res - end function psb_is_owned - - function psb_is_local(idx,desc) - implicit none - integer(psb_ipk_), intent(in) :: idx - type(psb_desc_type), intent(in) :: desc - logical :: psb_is_local - logical :: res - integer(psb_ipk_) :: info - - call psb_local_index(res,idx,desc,info) - if (info /= psb_success_) res=.false. - psb_is_local = res - end function psb_is_local - - subroutine psb_owned_index(res,idx,desc,info) - implicit none - integer(psb_ipk_), intent(in) :: idx - type(psb_desc_type), intent(in) :: desc - logical, intent(out) :: res - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: lx - - call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.true.) - - res = (lx>0) - end subroutine psb_owned_index - - subroutine psb_owned_index_v(res,idx,desc,info) - implicit none - integer(psb_ipk_), intent(in) :: idx(:) - type(psb_desc_type), intent(in) :: desc - logical, intent(out) :: res(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), allocatable :: lx(:) - - allocate(lx(size(idx)),stat=info) - res=.false. - if (info /= psb_success_) return - call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.true.) - - res = (lx>0) - end subroutine psb_owned_index_v - - subroutine psb_local_index(res,idx,desc,info) - implicit none - integer(psb_ipk_), intent(in) :: idx - type(psb_desc_type), intent(in) :: desc - logical, intent(out) :: res - integer(psb_ipk_), intent(out) :: info - - integer(psb_ipk_) :: lx - - call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.false.) - - res = (lx>0) - end subroutine psb_local_index - - subroutine psb_local_index_v(res,idx,desc,info) - implicit none - integer(psb_ipk_), intent(in) :: idx(:) - type(psb_desc_type), intent(in) :: desc - logical, intent(out) :: res(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), allocatable :: lx(:) - - allocate(lx(size(idx)),stat=info) - res=.false. - if (info /= psb_success_) return - call psb_glob_to_loc(idx,lx,desc,info,iact='I',owned=.false.) - - res = (lx>0) - end subroutine psb_local_index_v - end module psb_i_tools_mod diff --git a/base/modules/tools/psb_l_tools_mod.f90 b/base/modules/tools/psb_l_tools_mod.f90 new file mode 100644 index 000000000..4eca54f3e --- /dev/null +++ b/base/modules/tools/psb_l_tools_mod.f90 @@ -0,0 +1,174 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +Module psb_l_tools_mod + use psb_desc_mod, only : psb_desc_type, psb_ipk_, psb_lpk_, psb_success_ + use psb_l_vect_mod, only : psb_l_base_vect_type, psb_l_vect_type +! use psb_i_vect_mod, only : psb_i_vect_type + use psb_l_multivect_mod, only : psb_l_base_multivect_type, psb_l_multivect_type + + interface psb_geall + subroutine psb_lalloc_vect(x, desc_a,info,n) + import + implicit none + type(psb_l_vect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_lalloc_vect + subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb) + import + implicit none + type(psb_l_vect_type), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_lalloc_vect_r2 + subroutine psb_lalloc_multivect(x, desc_a,info,n) + import + implicit none + type(psb_l_multivect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_lalloc_multivect + end interface + + + interface psb_geasb + subroutine psb_lasb_vect(x, desc_a, info,mold, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine psb_lasb_vect + subroutine psb_lasb_vect_r2(x, desc_a, info,mold, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + end subroutine psb_lasb_vect_r2 + subroutine psb_lasb_multivect(x, desc_a, info,mold, scratch, n) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_lasb_multivect + end interface + + interface psb_gefree + subroutine psb_lfree_vect(x, desc_a, info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lfree_vect + subroutine psb_lfree_vect_r2(x, desc_a, info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lfree_vect_r2 + subroutine psb_lfree_multivect(x, desc_a, info) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + end subroutine psb_lfree_multivect + end interface + + + interface psb_geins + subroutine psb_lins_vect(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_lins_vect + subroutine psb_lins_vect_v(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), intent(inout) :: x + type(psb_l_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_lins_vect_v + subroutine psb_lins_vect_r2(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_lins_vect_r2 + subroutine psb_lins_multivect(m,irw,val,x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_multivect_type), intent(inout) :: x + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_lins_multivect + end interface + + +end module psb_l_tools_mod diff --git a/base/modules/tools/psb_m_tools_a_mod.f90 b/base/modules/tools/psb_m_tools_a_mod.f90 new file mode 100644 index 000000000..a5dfdd72d --- /dev/null +++ b/base/modules/tools/psb_m_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +Module psb_m_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_mpk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_malloc(x, desc_a, info, n, lb) + import + implicit none + integer(psb_mpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_malloc + subroutine psb_mallocv(x, desc_a,info,n) + import + implicit none + integer(psb_mpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_mallocv + end interface + + + interface psb_geasb + subroutine psb_masb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_masb + subroutine psb_masbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_masbv + end interface + + interface psb_gefree + subroutine psb_mfree(x, desc_a, info) + import + implicit none + integer(psb_mpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_mfree + subroutine psb_mfreev(x, desc_a, info) + import + implicit none + integer(psb_mpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_mfreev + end interface + + + interface psb_geins + subroutine psb_minsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_),intent(inout) :: x(:,:) + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_mpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_minsi + subroutine psb_minsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_),intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_mpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_minsvi + end interface + +end module psb_m_tools_a_mod diff --git a/base/modules/tools/psb_s_tools_a_mod.f90 b/base/modules/tools/psb_s_tools_a_mod.f90 new file mode 100644 index 000000000..32f445cb2 --- /dev/null +++ b/base/modules/tools/psb_s_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +Module psb_s_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_salloc(x, desc_a, info, n, lb) + import + implicit none + real(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_salloc + subroutine psb_sallocv(x, desc_a,info,n) + import + implicit none + real(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_sallocv + end interface + + + interface psb_geasb + subroutine psb_sasb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_sasb + subroutine psb_sasbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_sasbv + end interface + + interface psb_gefree + subroutine psb_sfree(x, desc_a, info) + import + implicit none + real(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sfree + subroutine psb_sfreev(x, desc_a, info) + import + implicit none + real(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sfreev + end interface + + + interface psb_geins + subroutine psb_sinsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_),intent(inout) :: x(:,:) + integer(psb_lpk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_sinsi + subroutine psb_sinsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_),intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_sinsvi + end interface + +end module psb_s_tools_a_mod diff --git a/base/modules/tools/psb_s_tools_mod.f90 b/base/modules/tools/psb_s_tools_mod.f90 index 77b7e9a97..aaed4bb18 100644 --- a/base/modules/tools/psb_s_tools_mod.f90 +++ b/base/modules/tools/psb_s_tools_mod.f90 @@ -30,28 +30,13 @@ ! ! Module psb_s_tools_mod - use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_ - use psb_s_vect_mod, only : psb_s_base_vect_type, psb_s_vect_type, psb_i_vect_type - use psb_s_mat_mod, only : psb_sspmat_type, psb_s_base_sparse_mat + use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_, psb_lpk_ + use psb_s_vect_mod, only : psb_s_base_vect_type, psb_s_vect_type + use psb_s_mat_mod, only : psb_sspmat_type, psb_lsspmat_type, psb_s_base_sparse_mat + use psb_l_vect_mod, only : psb_l_vect_type use psb_s_multivect_mod, only : psb_s_base_multivect_type, psb_s_multivect_type interface psb_geall - subroutine psb_salloc(x, desc_a, info, n, lb) - import - implicit none - real(psb_spk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_salloc - subroutine psb_sallocv(x, desc_a,info,n) - import - implicit none - real(psb_spk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_sallocv subroutine psb_salloc_vect(x, desc_a,info,n) import implicit none @@ -80,22 +65,6 @@ Module psb_s_tools_mod interface psb_geasb - subroutine psb_sasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_sasb - subroutine psb_sasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_sasbv subroutine psb_sasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -127,20 +96,6 @@ Module psb_s_tools_mod end interface interface psb_gefree - subroutine psb_sfree(x, desc_a, info) - import - implicit none - real(psb_spk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_sfree - subroutine psb_sfreev(x, desc_a, info) - import - implicit none - real(psb_spk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_sfreev subroutine psb_sfree_vect(x, desc_a, info) import implicit none @@ -166,37 +121,13 @@ Module psb_s_tools_mod interface psb_geins - subroutine psb_sinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_spk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_sinsi - subroutine psb_sinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_sinsvi subroutine psb_sins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_s_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_spk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -208,7 +139,7 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_s_vect_type), intent(inout) :: x - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_s_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -220,7 +151,7 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_s_vect_type), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -232,7 +163,7 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_s_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_spk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -266,6 +197,18 @@ Module psb_s_tools_mod character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_ssphalo + Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + import + implicit none + Type(psb_lsspmat_type),Intent(in) :: a + Type(psb_lsspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer(psb_ipk_), intent(in), optional :: data + end Subroutine psb_lssphalo end interface @@ -310,9 +253,10 @@ Module psb_s_tools_mod implicit none type(psb_desc_type), intent(inout) :: desc_a type(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild logical, intent(in), optional :: local end subroutine psb_sspins @@ -323,7 +267,7 @@ Module psb_s_tools_mod type(psb_desc_type), intent(inout) :: desc_a type(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz - type(psb_i_vect_type), intent(inout) :: ia,ja + type(psb_l_vect_type), intent(inout) :: ia,ja type(psb_s_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild @@ -335,9 +279,10 @@ Module psb_s_tools_mod type(psb_desc_type), intent(in) :: desc_ar type(psb_desc_type), intent(inout) :: desc_ac type(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_sspins_2desc end interface diff --git a/base/modules/tools/psb_tools_mod.f90 b/base/modules/tools/psb_tools_mod.f90 index a91b2b113..7f87ee794 100644 --- a/base/modules/tools/psb_tools_mod.f90 +++ b/base/modules/tools/psb_tools_mod.f90 @@ -31,7 +31,14 @@ ! module psb_tools_mod use psb_cd_tools_mod + use psb_e_tools_a_mod + use psb_m_tools_a_mod + use psb_s_tools_a_mod + use psb_d_tools_a_mod + use psb_c_tools_a_mod + use psb_z_tools_a_mod use psb_i_tools_mod + use psb_l_tools_mod use psb_s_tools_mod use psb_d_tools_mod use psb_c_tools_mod diff --git a/base/modules/tools/psb_z_tools_a_mod.f90 b/base/modules/tools/psb_z_tools_a_mod.f90 new file mode 100644 index 000000000..21f7ff0ff --- /dev/null +++ b/base/modules/tools/psb_z_tools_a_mod.f90 @@ -0,0 +1,119 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +Module psb_z_tools_a_mod + use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_ + + interface psb_geall + subroutine psb_zalloc(x, desc_a, info, n, lb) + import + implicit none + complex(psb_dpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + end subroutine psb_zalloc + subroutine psb_zallocv(x, desc_a,info,n) + import + implicit none + complex(psb_dpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + end subroutine psb_zallocv + end interface + + + interface psb_geasb + subroutine psb_zasb(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_zasb + subroutine psb_zasbv(x, desc_a, info, scratch) + import + implicit none + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + end subroutine psb_zasbv + end interface + + interface psb_gefree + subroutine psb_zfree(x, desc_a, info) + import + implicit none + complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zfree + subroutine psb_zfreev(x, desc_a, info) + import + implicit none + complex(psb_dpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zfreev + end interface + + + interface psb_geins + subroutine psb_zinsi(m,irw,val, x, desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_),intent(inout) :: x(:,:) + integer(psb_lpk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:,:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_zinsi + subroutine psb_zinsvi(m, irw,val, x,desc_a,info,dupl,local) + import + implicit none + integer(psb_ipk_), intent(in) :: m + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_),intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + end subroutine psb_zinsvi + end interface + +end module psb_z_tools_a_mod diff --git a/base/modules/tools/psb_z_tools_mod.f90 b/base/modules/tools/psb_z_tools_mod.f90 index 1fd7d1bdf..e4648d9f0 100644 --- a/base/modules/tools/psb_z_tools_mod.f90 +++ b/base/modules/tools/psb_z_tools_mod.f90 @@ -30,28 +30,13 @@ ! ! Module psb_z_tools_mod - use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_ - use psb_z_vect_mod, only : psb_z_base_vect_type, psb_z_vect_type, psb_i_vect_type - use psb_z_mat_mod, only : psb_zspmat_type, psb_z_base_sparse_mat + use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_, psb_lpk_ + use psb_z_vect_mod, only : psb_z_base_vect_type, psb_z_vect_type + use psb_z_mat_mod, only : psb_zspmat_type, psb_lzspmat_type, psb_z_base_sparse_mat + use psb_l_vect_mod, only : psb_l_vect_type use psb_z_multivect_mod, only : psb_z_base_multivect_type, psb_z_multivect_type interface psb_geall - subroutine psb_zalloc(x, desc_a, info, n, lb) - import - implicit none - complex(psb_dpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - end subroutine psb_zalloc - subroutine psb_zallocv(x, desc_a,info,n) - import - implicit none - complex(psb_dpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - end subroutine psb_zallocv subroutine psb_zalloc_vect(x, desc_a,info,n) import implicit none @@ -80,22 +65,6 @@ Module psb_z_tools_mod interface psb_geasb - subroutine psb_zasb(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_zasb - subroutine psb_zasbv(x, desc_a, info, scratch) - import - implicit none - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - end subroutine psb_zasbv subroutine psb_zasb_vect(x, desc_a, info,mold, scratch) import implicit none @@ -127,20 +96,6 @@ Module psb_z_tools_mod end interface interface psb_gefree - subroutine psb_zfree(x, desc_a, info) - import - implicit none - complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_zfree - subroutine psb_zfreev(x, desc_a, info) - import - implicit none - complex(psb_dpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - end subroutine psb_zfreev subroutine psb_zfree_vect(x, desc_a, info) import implicit none @@ -166,37 +121,13 @@ Module psb_z_tools_mod interface psb_geins - subroutine psb_zinsi(m,irw,val, x, desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_),intent(inout) :: x(:,:) - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_dpk_), intent(in) :: val(:,:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_zinsi - subroutine psb_zinsvi(m, irw,val, x,desc_a,info,dupl,local) - import - implicit none - integer(psb_ipk_), intent(in) :: m - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_),intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - end subroutine psb_zinsvi subroutine psb_zins_vect(m,irw,val,x,desc_a,info,dupl,local) import implicit none integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_z_vect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_dpk_), intent(in) :: val(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -208,7 +139,7 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_z_vect_type), intent(inout) :: x - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_z_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -220,7 +151,7 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_z_vect_type), intent(inout) :: x(:) - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -232,7 +163,7 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(in) :: m type(psb_desc_type), intent(in) :: desc_a type(psb_z_multivect_type), intent(inout) :: x - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_dpk_), intent(in) :: val(:,:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: dupl @@ -266,6 +197,18 @@ Module psb_z_tools_mod character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data end Subroutine psb_zsphalo + Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + import + implicit none + Type(psb_lzspmat_type),Intent(in) :: a + Type(psb_lzspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer(psb_ipk_), intent(in), optional :: data + end Subroutine psb_lzsphalo end interface @@ -310,9 +253,10 @@ Module psb_z_tools_mod implicit none type(psb_desc_type), intent(inout) :: desc_a type(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild logical, intent(in), optional :: local end subroutine psb_zspins @@ -323,7 +267,7 @@ Module psb_z_tools_mod type(psb_desc_type), intent(inout) :: desc_a type(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz - type(psb_i_vect_type), intent(inout) :: ia,ja + type(psb_l_vect_type), intent(inout) :: ia,ja type(psb_z_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild @@ -335,9 +279,10 @@ Module psb_z_tools_mod type(psb_desc_type), intent(in) :: desc_ar type(psb_desc_type), intent(inout) :: desc_ac type(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_zspins_2desc end interface diff --git a/base/psblas/psb_camax.f90 b/base/psblas/psb_camax.f90 index f9a11055b..526c5e40b 100644 --- a/base/psblas/psb_camax.f90 +++ b/base/psblas/psb_camax.f90 @@ -58,14 +58,17 @@ function psb_camax(x,desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_camax' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() @@ -93,7 +96,7 @@ function psb_camax(x,desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -183,14 +186,17 @@ function psb_camaxv (x,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_camaxv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -214,7 +220,7 @@ function psb_camaxv (x,desc_a, info,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -264,14 +270,17 @@ function psb_camax_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_camaxv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -298,7 +307,7 @@ function psb_camax_vect(x, desc_a, info,global) result(res) jx = 1 m = desc_a%get_global_rows() - call psb_chkvect(m,ione,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -391,14 +400,17 @@ subroutine psb_camaxvs(res,x,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_camaxvs' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() @@ -421,7 +433,7 @@ subroutine psb_camaxvs(res,x,desc_a, info,global) m = desc_a%get_global_rows() ldx=size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -511,14 +523,17 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx, i, k + & err_act, iix, jjx, ldx, i, k + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_cmamaxs' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -545,7 +560,7 @@ subroutine psb_cmamaxs(res,x,desc_a, info,jx,global) m = desc_a%get_global_rows() k = min(size(x,2),size(res,1)) ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/psblas/psb_casum.f90 b/base/psblas/psb_casum.f90 index c9e294616..2b0beda58 100644 --- a/base/psblas/psb_casum.f90 +++ b/base/psblas/psb_casum.f90 @@ -58,14 +58,17 @@ function psb_casum (x,desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, & - & err_act, iix, jjx, ix, ijx, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_casum' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -93,7 +96,7 @@ function psb_casum (x,desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -145,12 +148,15 @@ function psb_casum_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, imax, i, idx, ndm + & err_act, iix, jjx, imax, i, idx, ndm + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_casumv' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info=psb_success_ call psb_erractionsave(err_act) @@ -180,7 +186,7 @@ function psb_casum_vect(x, desc_a, info,global) result(res) jx = 1 m = desc_a%get_global_rows() - call psb_chkvect(m,ione,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -279,14 +285,17 @@ function psb_casumv(x,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_casumv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -309,7 +318,7 @@ function psb_casumv(x,desc_a, info,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -407,14 +416,17 @@ subroutine psb_casumvs(res,x,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, jx, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_casumvs' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -437,7 +449,7 @@ subroutine psb_casumvs(res,x,desc_a, info,global) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index 66e6512db..ab00bd60b 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -43,7 +43,8 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, m, iiy, jjy + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err name='psb_cgeaxpby' @@ -77,14 +78,14 @@ subroutine psb_caxpby_vect(alpha, x, beta, y,& m = desc_a%get_global_rows() ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ione,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,y%get_nrows(),iy,ione,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' @@ -145,14 +146,16 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, ijx, ijy, m, iiy, in, jjy, & - & lldx, lldy + & err_act, iix, jjx, iiy, in, jjy, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -197,9 +200,9 @@ subroutine psb_caxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -291,15 +294,17 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, m, iiy, jjy, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err logical, parameter :: debug=.false. name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -317,14 +322,14 @@ subroutine psb_caxpbyv(alpha, x, beta,y,desc_a,info) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ione,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,lone,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,lldy,iy,ione,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,lldy,iy,lone,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' diff --git a/base/psblas/psb_cdot.f90 b/base/psblas/psb_cdot.f90 index c6d545c64..39cda4312 100644 --- a/base/psblas/psb_cdot.f90 +++ b/base/psblas/psb_cdot.f90 @@ -65,15 +65,18 @@ function psb_cdot_vect(x, y, desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr + & err_act, iix, jjx, iiy, jjy, i, nr + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_cdot_vect' res = czero - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -108,9 +111,9 @@ function psb_cdot_vect(x, y, desc_a,info,global) result(res) m = desc_a%get_global_rows() ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -167,16 +170,18 @@ function psb_cdot(x, y,desc_a, info, jx, jy,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m complex(psb_spk_) :: cdotc logical :: global_ character(len=20) :: name, ch_err name='psb_cdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -217,9 +222,9 @@ function psb_cdot(x, y,desc_a, info, jx, jy,global) result(res) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -235,7 +240,7 @@ function psb_cdot(x, y,desc_a, info, jx, jy,global) result(res) nr = desc_a%get_local_rows() if(nr > 0) then - res = cdotc(int(nr,kind=psb_mpik_), x(iix:,jjx),1,y(iiy:,jjy),1) + res = cdotc(int(nr,kind=psb_mpk_), x(iix:,jjx),1,y(iiy:,jjy),1) ! adjust dot_local because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -315,16 +320,18 @@ function psb_cdotv(x, y,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy + integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ complex(psb_spk_) :: cdotc character(len=20) :: name, ch_err name='psb_cdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -349,9 +356,9 @@ function psb_cdotv(x, y,desc_a, info,global) result(res) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_)& - & call psb_chkvect(m,ione,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -367,7 +374,7 @@ function psb_cdotv(x, y,desc_a, info,global) result(res) nr = desc_a%get_local_rows() if(nr > 0) then - res = cdotc(int(nr,kind=psb_mpik_), x,1,y,1) + res = cdotc(int(nr,kind=psb_mpk_), x,1,y,1) ! adjust res because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -448,16 +455,18 @@ subroutine psb_cdotvs(res, x, y,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, iy, iiy, jjy, i, m,nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i,nr, lldx, lldy + integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ complex(psb_spk_) :: cdotc character(len=20) :: name, ch_err name='psb_cdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -480,9 +489,9 @@ subroutine psb_cdotvs(res, x, y,desc_a, info,global) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ix,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ix,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,iy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,iy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -498,7 +507,7 @@ subroutine psb_cdotvs(res, x, y,desc_a, info,global) nr = desc_a%get_local_rows() if(nr > 0) then - res = cdotc(int(nr,kind=psb_mpik_), x,1,y,1) + res = cdotc(int(nr,kind=psb_mpk_), x,1,y,1) ! adjust res because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -579,16 +588,18 @@ subroutine psb_cmdots(res, x, y, desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, j, k, nr, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ complex(psb_spk_) :: cdotc character(len=20) :: name, ch_err name='psb_cmdots' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -612,14 +623,14 @@ subroutine psb_cmdots(res, x, y, desc_a, info,global) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ix,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ix,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,lldy,iy,iy,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,lldy,iy,iy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -638,7 +649,7 @@ subroutine psb_cmdots(res, x, y, desc_a, info,global) nr = desc_a%get_local_rows() if(nr > 0) then do j=1,k - res(j) = cdotc(int(nr,kind=psb_mpik_),x(1:,j),1,y(1:,j),1) + res(j) = cdotc(int(nr,kind=psb_mpk_),x(1:,j),1,y(1:,j),1) ! adjust res because overlapped elements are computed more than once end do do i=1,size(desc_a%ovrlap_elem,1) diff --git a/base/psblas/psb_cnrm2.f90 b/base/psblas/psb_cnrm2.f90 index f54db995f..43ab876c8 100644 --- a/base/psblas/psb_cnrm2.f90 +++ b/base/psblas/psb_cnrm2.f90 @@ -60,15 +60,18 @@ function psb_cnrm2(x, desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ real(psb_spk_) :: scnrm2, dd character(len=20) :: name, ch_err name='psb_cnrm2' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -94,7 +97,7 @@ function psb_cnrm2(x, desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -109,7 +112,7 @@ function psb_cnrm2(x, desc_a, info, jx,global) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = scnrm2( int(ndim,kind=psb_mpik_), x(iix:,jjx), int(ione,kind=psb_mpik_) ) + res = scnrm2( int(ndim,kind=psb_mpk_), x(iix:,jjx), int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) @@ -191,15 +194,18 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx - logical :: global_ + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m real(psb_spk_) :: scnrm2, dd + logical :: global_ character(len=20) :: name, ch_err name='psb_cnrm2v' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -219,7 +225,7 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) jx=1 m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -234,7 +240,7 @@ function psb_cnrm2v(x, desc_a, info,global) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = scnrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) + res = scnrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -274,13 +280,16 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ real(psb_spk_) :: snrm2, dd character(len=20) :: name, ch_err name='psb_cnrm2v' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info=psb_success_ call psb_erractionsave(err_act) @@ -306,10 +315,10 @@ function psb_cnrm2_vect(x, desc_a, info,global) result(res) end if ix = 1 - jx=1 - m = desc_a%get_global_rows() + jx = 1 + m = desc_a%get_global_rows() ldx = x%get_nrows() - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -408,15 +417,18 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ real(psb_spk_) :: nrm2, scnrm2, dd character(len=20) :: name, ch_err name='psb_cnrm2' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -437,7 +449,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) jx = 1 m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -452,7 +464,7 @@ subroutine psb_cnrm2vs(res, x, desc_a, info,global) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = scnrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) + res = scnrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) diff --git a/base/psblas/psb_cnrmi.f90 b/base/psblas/psb_cnrmi.f90 index 9a89a02a5..0ac0a04bd 100644 --- a/base/psblas/psb_cnrmi.f90 +++ b/base/psblas/psb_cnrmi.f90 @@ -53,14 +53,17 @@ function psb_cnrmi(a,desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iia, jja, ia, ja, mdim, ndim, m + & err_act, iia, jja, mdim, ndim + integer(psb_lpk_) :: m, n, ia, ja logical :: global_ character(len=20) :: name, ch_err name='psb_cnrmi' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/psblas/psb_cspmm.f90 b/base/psblas/psb_cspmm.f90 index 533a771e4..d99909c5d 100644 --- a/base/psblas/psb_cspmm.f90 +++ b/base/psblas/psb_cspmm.f90 @@ -81,9 +81,9 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, ijx, ijy,& - & m, nrow, ncol, lldx, lldy, liwork, iiy, jjy,& - & i, ib, ib1, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, i, ib, ib1, ip, idx, ik + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik integer(psb_ipk_), parameter :: nb=4 complex(psb_spk_), pointer :: xp(:,:), yp(:,:), iwork(:) complex(psb_spk_), allocatable :: xvsave(:,:) @@ -93,9 +93,11 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_cspmm' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -132,10 +134,10 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& endif if (present(k)) then - ik = min(k,size(x,2)-ijx+1) - ik = min(ik,size(y,2)-ijy+1) + lik = min(k,size(x,2)-ijx+1) + lik = min(lik,size(y,2)-ijy+1) else - ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) endif if (present(trans)) then @@ -205,9 +207,9 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(n,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(n,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -224,16 +226,16 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& if (doswap_.and.(np>1)) then - ib1=min(nb,ik) + ib1=min(nb,lik) xp => x(iix:lldx,jjx:jjx+ib1-1) if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,czero,xp,desc_a,iwork,info) - blk: do i=1, ik, nb + blk: do i=1, lik, nb ib=ib1 - ib1 = max(0,min(nb,(ik)-(i-1+ib))) + ib1 = max(0,min(nb,(lik)-(i-1+ib))) xp => x(iix:lldx,jjx+i-1+ib:jjx+i-1+ib+ib1-1) if ((ib1 > 0).and.(doswap_)) & & call psi_swapdata(psb_swap_send_,ib1,& @@ -256,8 +258,8 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& else if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& - & ib1,czero,x(:,1:ik),desc_a,iwork,info) - if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + & ib1,czero,x(:,1:lik),desc_a,iwork,info) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:lik),beta,y(:,1:lik),info) end if if(info /= psb_success_) then info = psb_err_from_subroutine_non_ @@ -277,9 +279,9 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness - call psb_chkvect(m,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(n,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(n,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -300,12 +302,12 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& ! Why the average? because in this way they will contribute ! with a proper scale factor (1/np) to the overall product. ! - call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) + call psi_ovrl_save(x(:,1:lik),xvsave,desc_a,info) if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) - y(nrow+1:ncol,1:ik) = czero + y(nrow+1:ncol,1:lik) = czero if (info == psb_success_) & - & call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + & call psb_csmm(alpha,a,x(:,1:lik),beta,y(:,1:lik),info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info if (info /= psb_success_) then @@ -316,7 +318,9 @@ subroutine psb_cspmm(alpha,a,x,beta,y,desc_a,info,& end if if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) - if (doswap_)then + if (doswap_)then + ik = lik ! This should not be an issue, we are expecting the values + ! to be small, within IPK call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,cone,y(:,1:ik),desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& @@ -428,9 +432,9 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & - & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, ib, ip, idx, ik + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy integer(psb_ipk_), parameter :: nb=4 complex(psb_spk_), pointer :: iwork(:), xp(:), yp(:) complex(psb_spk_), allocatable :: xvsave(:) @@ -440,9 +444,11 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_cspmv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -461,6 +467,7 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& iy = 1 jy = 1 ik = 1 + lik = 1 ib = 1 if (present(doswap)) then @@ -538,9 +545,9 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(n,ik,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(n,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -578,9 +585,9 @@ subroutine psb_cspmv(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_)& - & call psb_chkvect(n,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(n,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -684,9 +691,9 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & - & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, ib, ip, idx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja integer(psb_ipk_), parameter :: nb=4 complex(psb_spk_), pointer :: iwork(:), xp(:), yp(:) complex(psb_spk_), allocatable :: xvsave(:) @@ -696,9 +703,11 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_cspmv' - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/psblas/psb_cspnrm1.f90 b/base/psblas/psb_cspnrm1.f90 index 79907295c..a5076a0ad 100644 --- a/base/psblas/psb_cspnrm1.f90 +++ b/base/psblas/psb_cspnrm1.f90 @@ -53,7 +53,8 @@ function psb_cspnrm1(a,desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, nr,nc,& - & err_act, n, iia, jja, ia, ja, mdim, ndim, m + & err_act, iia, jja, mdim, ndim + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja logical :: global_ character(len=20) :: name, ch_err real(psb_spk_), allocatable :: v(:) diff --git a/base/psblas/psb_cspsm.f90 b/base/psblas/psb_cspsm.f90 index 034f98e03..5d00de899 100644 --- a/base/psblas/psb_cspsm.f90 +++ b/base/psblas/psb_cspsm.f90 @@ -93,10 +93,10 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& - & ix, iy, ik, ijx, ijy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& + & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik character :: lscale integer(psb_ipk_), parameter :: nb=4 complex(psb_spk_),pointer :: iwork(:), xp(:,:), yp(:,:), id(:) @@ -105,9 +105,11 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_cspsm' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -137,10 +139,10 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& endif if (present(k)) then - ik = min(k,size(x,2)-ijx+1) - ik = min(ik,size(y,2)-ijy+1) + lik = min(k,size(x,2)-ijx+1) + lik = min(lik,size(y,2)-ijy+1) else - ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) endif if (present(choice)) then @@ -220,9 +222,9 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness if (info == psb_success_) & - & call psb_chkvect(m,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + & call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' @@ -245,6 +247,8 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if + ik = lik ! This should not be a problem. + ! We expect ik to be small, well within IPK ! Perform local triangular system solve xp => x(iix:lldx,jjx:jjx+ik-1) yp => y(iiy:lldy,jjy:jjy+ik-1) @@ -259,7 +263,6 @@ subroutine psb_cspsm(alpha,a,x,beta,y,desc_a,info,& ! update overlap elements if (choice_ > 0) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & cone,yp,desc_a,iwork,info,data=psb_comm_ovr_) @@ -366,9 +369,9 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me, & - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& - & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& + & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy character :: lscale integer(psb_ipk_), parameter :: nb=4 @@ -378,9 +381,11 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_cspsv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -396,9 +401,10 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& ja = 1 ix = 1 iy = 1 + lik = 1 ik = 1 - jx= 1 - jy= 1 + jx = 1 + jy = 1 if (present(choice)) then choice_ = choice @@ -478,9 +484,9 @@ subroutine psb_cspsv(alpha,a,x,beta,y,desc_a,info,& call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness if (info == psb_success_) & - & call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx) + & call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' @@ -571,9 +577,11 @@ subroutine psb_cspsv_vect(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_sspsv' - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/psblas/psb_damax.f90 b/base/psblas/psb_damax.f90 index 4307ba085..33dd2dc95 100644 --- a/base/psblas/psb_damax.f90 +++ b/base/psblas/psb_damax.f90 @@ -58,14 +58,17 @@ function psb_damax(x,desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_damax' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() @@ -93,7 +96,7 @@ function psb_damax(x,desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -183,14 +186,17 @@ function psb_damaxv (x,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_damaxv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -214,7 +220,7 @@ function psb_damaxv (x,desc_a, info,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -264,14 +270,17 @@ function psb_damax_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_damaxv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -298,7 +307,7 @@ function psb_damax_vect(x, desc_a, info,global) result(res) jx = 1 m = desc_a%get_global_rows() - call psb_chkvect(m,ione,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -391,14 +400,17 @@ subroutine psb_damaxvs(res,x,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_damaxvs' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() @@ -421,7 +433,7 @@ subroutine psb_damaxvs(res,x,desc_a, info,global) m = desc_a%get_global_rows() ldx=size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -511,14 +523,17 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx, i, k + & err_act, iix, jjx, ldx, i, k + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_dmamaxs' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -545,7 +560,7 @@ subroutine psb_dmamaxs(res,x,desc_a, info,jx,global) m = desc_a%get_global_rows() k = min(size(x,2),size(res,1)) ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/psblas/psb_dasum.f90 b/base/psblas/psb_dasum.f90 index 654df8ef9..cf2d8fe36 100644 --- a/base/psblas/psb_dasum.f90 +++ b/base/psblas/psb_dasum.f90 @@ -58,14 +58,17 @@ function psb_dasum (x,desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, & - & err_act, iix, jjx, ix, ijx, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_dasum' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -93,7 +96,7 @@ function psb_dasum (x,desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -145,12 +148,15 @@ function psb_dasum_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, imax, i, idx, ndm + & err_act, iix, jjx, imax, i, idx, ndm + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_dasumv' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info=psb_success_ call psb_erractionsave(err_act) @@ -180,7 +186,7 @@ function psb_dasum_vect(x, desc_a, info,global) result(res) jx = 1 m = desc_a%get_global_rows() - call psb_chkvect(m,ione,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -279,14 +285,17 @@ function psb_dasumv(x,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_dasumv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -309,7 +318,7 @@ function psb_dasumv(x,desc_a, info,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -407,14 +416,17 @@ subroutine psb_dasumvs(res,x,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, jx, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_dasumvs' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -437,7 +449,7 @@ subroutine psb_dasumvs(res,x,desc_a, info,global) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index a67e10553..b1c83d3a6 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -43,7 +43,8 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, m, iiy, jjy + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err name='psb_dgeaxpby' @@ -77,14 +78,14 @@ subroutine psb_daxpby_vect(alpha, x, beta, y,& m = desc_a%get_global_rows() ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ione,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,y%get_nrows(),iy,ione,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' @@ -145,14 +146,16 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, ijx, ijy, m, iiy, in, jjy, & - & lldx, lldy + & err_act, iix, jjx, iiy, in, jjy, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -197,9 +200,9 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -291,15 +294,17 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, m, iiy, jjy, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err logical, parameter :: debug=.false. name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -317,14 +322,14 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ione,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,lone,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,lldy,iy,ione,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,lldy,iy,lone,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' diff --git a/base/psblas/psb_ddot.f90 b/base/psblas/psb_ddot.f90 index a679003f5..c2231d8ac 100644 --- a/base/psblas/psb_ddot.f90 +++ b/base/psblas/psb_ddot.f90 @@ -65,15 +65,18 @@ function psb_ddot_vect(x, y, desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr + & err_act, iix, jjx, iiy, jjy, i, nr + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_ddot_vect' res = dzero - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -108,9 +111,9 @@ function psb_ddot_vect(x, y, desc_a,info,global) result(res) m = desc_a%get_global_rows() ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -167,16 +170,18 @@ function psb_ddot(x, y,desc_a, info, jx, jy,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m real(psb_dpk_) :: ddot logical :: global_ character(len=20) :: name, ch_err name='psb_ddot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -217,9 +222,9 @@ function psb_ddot(x, y,desc_a, info, jx, jy,global) result(res) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -235,7 +240,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy,global) result(res) nr = desc_a%get_local_rows() if(nr > 0) then - res = ddot(int(nr,kind=psb_mpik_), x(iix:,jjx),1,y(iiy:,jjy),1) + res = ddot(int(nr,kind=psb_mpk_), x(iix:,jjx),1,y(iiy:,jjy),1) ! adjust dot_local because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -315,16 +320,18 @@ function psb_ddotv(x, y,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy + integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ real(psb_dpk_) :: ddot character(len=20) :: name, ch_err name='psb_ddot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -349,9 +356,9 @@ function psb_ddotv(x, y,desc_a, info,global) result(res) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_)& - & call psb_chkvect(m,ione,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -367,7 +374,7 @@ function psb_ddotv(x, y,desc_a, info,global) result(res) nr = desc_a%get_local_rows() if(nr > 0) then - res = ddot(int(nr,kind=psb_mpik_), x,1,y,1) + res = ddot(int(nr,kind=psb_mpk_), x,1,y,1) ! adjust res because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -448,16 +455,18 @@ subroutine psb_ddotvs(res, x, y,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, iy, iiy, jjy, i, m,nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i,nr, lldx, lldy + integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ real(psb_dpk_) :: ddot character(len=20) :: name, ch_err name='psb_ddot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -480,9 +489,9 @@ subroutine psb_ddotvs(res, x, y,desc_a, info,global) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ix,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ix,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,iy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,iy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -498,7 +507,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info,global) nr = desc_a%get_local_rows() if(nr > 0) then - res = ddot(int(nr,kind=psb_mpik_), x,1,y,1) + res = ddot(int(nr,kind=psb_mpk_), x,1,y,1) ! adjust res because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -579,16 +588,18 @@ subroutine psb_dmdots(res, x, y, desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, j, k, nr, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ real(psb_dpk_) :: ddot character(len=20) :: name, ch_err name='psb_dmdots' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -612,14 +623,14 @@ subroutine psb_dmdots(res, x, y, desc_a, info,global) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ix,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ix,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,lldy,iy,iy,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,lldy,iy,iy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -638,7 +649,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info,global) nr = desc_a%get_local_rows() if(nr > 0) then do j=1,k - res(j) = ddot(int(nr,kind=psb_mpik_),x(1:,j),1,y(1:,j),1) + res(j) = ddot(int(nr,kind=psb_mpk_),x(1:,j),1,y(1:,j),1) ! adjust res because overlapped elements are computed more than once end do do i=1,size(desc_a%ovrlap_elem,1) diff --git a/base/psblas/psb_dnrm2.f90 b/base/psblas/psb_dnrm2.f90 index 66eeca93f..b72a72eea 100644 --- a/base/psblas/psb_dnrm2.f90 +++ b/base/psblas/psb_dnrm2.f90 @@ -60,15 +60,18 @@ function psb_dnrm2(x, desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ real(psb_dpk_) :: dnrm2, dd character(len=20) :: name, ch_err name='psb_dnrm2' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -94,7 +97,7 @@ function psb_dnrm2(x, desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -109,7 +112,7 @@ function psb_dnrm2(x, desc_a, info, jx,global) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = dnrm2( int(ndim,kind=psb_mpik_), x(iix:,jjx), int(ione,kind=psb_mpik_) ) + res = dnrm2( int(ndim,kind=psb_mpk_), x(iix:,jjx), int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) @@ -191,15 +194,18 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx - logical :: global_ + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m real(psb_dpk_) :: dnrm2, dd + logical :: global_ character(len=20) :: name, ch_err name='psb_dnrm2v' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -219,7 +225,7 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) jx=1 m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -234,7 +240,7 @@ function psb_dnrm2v(x, desc_a, info,global) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = dnrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) + res = dnrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -274,13 +280,16 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ real(psb_dpk_) :: snrm2, dd character(len=20) :: name, ch_err name='psb_dnrm2v' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info=psb_success_ call psb_erractionsave(err_act) @@ -306,10 +315,10 @@ function psb_dnrm2_vect(x, desc_a, info,global) result(res) end if ix = 1 - jx=1 - m = desc_a%get_global_rows() + jx = 1 + m = desc_a%get_global_rows() ldx = x%get_nrows() - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -408,15 +417,18 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ real(psb_dpk_) :: nrm2, dnrm2, dd character(len=20) :: name, ch_err name='psb_dnrm2' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -437,7 +449,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) jx = 1 m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -452,7 +464,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info,global) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = dnrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) + res = dnrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) diff --git a/base/psblas/psb_dnrmi.f90 b/base/psblas/psb_dnrmi.f90 index 9cb0edfe2..6d585981e 100644 --- a/base/psblas/psb_dnrmi.f90 +++ b/base/psblas/psb_dnrmi.f90 @@ -53,14 +53,17 @@ function psb_dnrmi(a,desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iia, jja, ia, ja, mdim, ndim, m + & err_act, iia, jja, mdim, ndim + integer(psb_lpk_) :: m, n, ia, ja logical :: global_ character(len=20) :: name, ch_err name='psb_dnrmi' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/psblas/psb_dspmm.f90 b/base/psblas/psb_dspmm.f90 index 2d5568279..edf4e32e7 100644 --- a/base/psblas/psb_dspmm.f90 +++ b/base/psblas/psb_dspmm.f90 @@ -81,9 +81,9 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, ijx, ijy,& - & m, nrow, ncol, lldx, lldy, liwork, iiy, jjy,& - & i, ib, ib1, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, i, ib, ib1, ip, idx, ik + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik integer(psb_ipk_), parameter :: nb=4 real(psb_dpk_), pointer :: xp(:,:), yp(:,:), iwork(:) real(psb_dpk_), allocatable :: xvsave(:,:) @@ -93,9 +93,11 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_dspmm' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -132,10 +134,10 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& endif if (present(k)) then - ik = min(k,size(x,2)-ijx+1) - ik = min(ik,size(y,2)-ijy+1) + lik = min(k,size(x,2)-ijx+1) + lik = min(lik,size(y,2)-ijy+1) else - ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) endif if (present(trans)) then @@ -205,9 +207,9 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(n,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(n,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -224,16 +226,16 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& if (doswap_.and.(np>1)) then - ib1=min(nb,ik) + ib1=min(nb,lik) xp => x(iix:lldx,jjx:jjx+ib1-1) if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,dzero,xp,desc_a,iwork,info) - blk: do i=1, ik, nb + blk: do i=1, lik, nb ib=ib1 - ib1 = max(0,min(nb,(ik)-(i-1+ib))) + ib1 = max(0,min(nb,(lik)-(i-1+ib))) xp => x(iix:lldx,jjx+i-1+ib:jjx+i-1+ib+ib1-1) if ((ib1 > 0).and.(doswap_)) & & call psi_swapdata(psb_swap_send_,ib1,& @@ -256,8 +258,8 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& else if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& - & ib1,dzero,x(:,1:ik),desc_a,iwork,info) - if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + & ib1,dzero,x(:,1:lik),desc_a,iwork,info) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:lik),beta,y(:,1:lik),info) end if if(info /= psb_success_) then info = psb_err_from_subroutine_non_ @@ -277,9 +279,9 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness - call psb_chkvect(m,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(n,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(n,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -300,12 +302,12 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& ! Why the average? because in this way they will contribute ! with a proper scale factor (1/np) to the overall product. ! - call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) + call psi_ovrl_save(x(:,1:lik),xvsave,desc_a,info) if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) - y(nrow+1:ncol,1:ik) = dzero + y(nrow+1:ncol,1:lik) = dzero if (info == psb_success_) & - & call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + & call psb_csmm(alpha,a,x(:,1:lik),beta,y(:,1:lik),info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info if (info /= psb_success_) then @@ -316,7 +318,9 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,& end if if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) - if (doswap_)then + if (doswap_)then + ik = lik ! This should not be an issue, we are expecting the values + ! to be small, within IPK call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,done,y(:,1:ik),desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& @@ -428,9 +432,9 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & - & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, ib, ip, idx, ik + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy integer(psb_ipk_), parameter :: nb=4 real(psb_dpk_), pointer :: iwork(:), xp(:), yp(:) real(psb_dpk_), allocatable :: xvsave(:) @@ -440,9 +444,11 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_dspmv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -461,6 +467,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& iy = 1 jy = 1 ik = 1 + lik = 1 ib = 1 if (present(doswap)) then @@ -538,9 +545,9 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(n,ik,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(n,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -578,9 +585,9 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_)& - & call psb_chkvect(n,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(n,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -684,9 +691,9 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & - & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, ib, ip, idx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja integer(psb_ipk_), parameter :: nb=4 real(psb_dpk_), pointer :: iwork(:), xp(:), yp(:) real(psb_dpk_), allocatable :: xvsave(:) @@ -696,9 +703,11 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_dspmv' - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/psblas/psb_dspnrm1.f90 b/base/psblas/psb_dspnrm1.f90 index dff6a2329..01a7de960 100644 --- a/base/psblas/psb_dspnrm1.f90 +++ b/base/psblas/psb_dspnrm1.f90 @@ -53,7 +53,8 @@ function psb_dspnrm1(a,desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, nr,nc,& - & err_act, n, iia, jja, ia, ja, mdim, ndim, m + & err_act, iia, jja, mdim, ndim + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja logical :: global_ character(len=20) :: name, ch_err real(psb_dpk_), allocatable :: v(:) diff --git a/base/psblas/psb_dspsm.f90 b/base/psblas/psb_dspsm.f90 index 68fa718a1..6782b22b7 100644 --- a/base/psblas/psb_dspsm.f90 +++ b/base/psblas/psb_dspsm.f90 @@ -93,10 +93,10 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& - & ix, iy, ik, ijx, ijy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& + & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik character :: lscale integer(psb_ipk_), parameter :: nb=4 real(psb_dpk_),pointer :: iwork(:), xp(:,:), yp(:,:), id(:) @@ -105,9 +105,11 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_dspsm' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -137,10 +139,10 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& endif if (present(k)) then - ik = min(k,size(x,2)-ijx+1) - ik = min(ik,size(y,2)-ijy+1) + lik = min(k,size(x,2)-ijx+1) + lik = min(lik,size(y,2)-ijy+1) else - ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) endif if (present(choice)) then @@ -220,9 +222,9 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness if (info == psb_success_) & - & call psb_chkvect(m,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + & call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' @@ -245,6 +247,8 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if + ik = lik ! This should not be a problem. + ! We expect ik to be small, well within IPK ! Perform local triangular system solve xp => x(iix:lldx,jjx:jjx+ik-1) yp => y(iiy:lldy,jjy:jjy+ik-1) @@ -259,7 +263,6 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,& ! update overlap elements if (choice_ > 0) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & done,yp,desc_a,iwork,info,data=psb_comm_ovr_) @@ -366,9 +369,9 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me, & - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& - & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& + & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy character :: lscale integer(psb_ipk_), parameter :: nb=4 @@ -378,9 +381,11 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_dspsv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -396,9 +401,10 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& ja = 1 ix = 1 iy = 1 + lik = 1 ik = 1 - jx= 1 - jy= 1 + jx = 1 + jy = 1 if (present(choice)) then choice_ = choice @@ -478,9 +484,9 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,& call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness if (info == psb_success_) & - & call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx) + & call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' @@ -571,9 +577,11 @@ subroutine psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_sspsv' - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/psblas/psb_samax.f90 b/base/psblas/psb_samax.f90 index a92ceb91c..ee70314f3 100644 --- a/base/psblas/psb_samax.f90 +++ b/base/psblas/psb_samax.f90 @@ -58,14 +58,17 @@ function psb_samax(x,desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_samax' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() @@ -93,7 +96,7 @@ function psb_samax(x,desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -183,14 +186,17 @@ function psb_samaxv (x,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_samaxv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -214,7 +220,7 @@ function psb_samaxv (x,desc_a, info,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -264,14 +270,17 @@ function psb_samax_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_samaxv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -298,7 +307,7 @@ function psb_samax_vect(x, desc_a, info,global) result(res) jx = 1 m = desc_a%get_global_rows() - call psb_chkvect(m,ione,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -391,14 +400,17 @@ subroutine psb_samaxvs(res,x,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_samaxvs' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() @@ -421,7 +433,7 @@ subroutine psb_samaxvs(res,x,desc_a, info,global) m = desc_a%get_global_rows() ldx=size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -511,14 +523,17 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx, i, k + & err_act, iix, jjx, ldx, i, k + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_smamaxs' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -545,7 +560,7 @@ subroutine psb_smamaxs(res,x,desc_a, info,jx,global) m = desc_a%get_global_rows() k = min(size(x,2),size(res,1)) ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/psblas/psb_sasum.f90 b/base/psblas/psb_sasum.f90 index e4fe548e0..2abf254d7 100644 --- a/base/psblas/psb_sasum.f90 +++ b/base/psblas/psb_sasum.f90 @@ -58,14 +58,17 @@ function psb_sasum (x,desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, & - & err_act, iix, jjx, ix, ijx, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_sasum' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -93,7 +96,7 @@ function psb_sasum (x,desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -145,12 +148,15 @@ function psb_sasum_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, imax, i, idx, ndm + & err_act, iix, jjx, imax, i, idx, ndm + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_sasumv' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info=psb_success_ call psb_erractionsave(err_act) @@ -180,7 +186,7 @@ function psb_sasum_vect(x, desc_a, info,global) result(res) jx = 1 m = desc_a%get_global_rows() - call psb_chkvect(m,ione,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -279,14 +285,17 @@ function psb_sasumv(x,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_sasumv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -309,7 +318,7 @@ function psb_sasumv(x,desc_a, info,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -407,14 +416,17 @@ subroutine psb_sasumvs(res,x,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, jx, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_sasumvs' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -437,7 +449,7 @@ subroutine psb_sasumvs(res,x,desc_a, info,global) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index 97fd4e7f4..26cecd304 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -43,7 +43,8 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, m, iiy, jjy + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err name='psb_sgeaxpby' @@ -77,14 +78,14 @@ subroutine psb_saxpby_vect(alpha, x, beta, y,& m = desc_a%get_global_rows() ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ione,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,y%get_nrows(),iy,ione,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' @@ -145,14 +146,16 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, ijx, ijy, m, iiy, in, jjy, & - & lldx, lldy + & err_act, iix, jjx, iiy, in, jjy, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -197,9 +200,9 @@ subroutine psb_saxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -291,15 +294,17 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, m, iiy, jjy, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err logical, parameter :: debug=.false. name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -317,14 +322,14 @@ subroutine psb_saxpbyv(alpha, x, beta,y,desc_a,info) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ione,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,lone,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,lldy,iy,ione,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,lldy,iy,lone,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' diff --git a/base/psblas/psb_sdot.f90 b/base/psblas/psb_sdot.f90 index 5afb520d8..2c8bea516 100644 --- a/base/psblas/psb_sdot.f90 +++ b/base/psblas/psb_sdot.f90 @@ -65,15 +65,18 @@ function psb_sdot_vect(x, y, desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr + & err_act, iix, jjx, iiy, jjy, i, nr + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_sdot_vect' res = szero - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -108,9 +111,9 @@ function psb_sdot_vect(x, y, desc_a,info,global) result(res) m = desc_a%get_global_rows() ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -167,16 +170,18 @@ function psb_sdot(x, y,desc_a, info, jx, jy,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m real(psb_spk_) :: sdot logical :: global_ character(len=20) :: name, ch_err name='psb_sdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -217,9 +222,9 @@ function psb_sdot(x, y,desc_a, info, jx, jy,global) result(res) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -235,7 +240,7 @@ function psb_sdot(x, y,desc_a, info, jx, jy,global) result(res) nr = desc_a%get_local_rows() if(nr > 0) then - res = sdot(int(nr,kind=psb_mpik_), x(iix:,jjx),1,y(iiy:,jjy),1) + res = sdot(int(nr,kind=psb_mpk_), x(iix:,jjx),1,y(iiy:,jjy),1) ! adjust dot_local because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -315,16 +320,18 @@ function psb_sdotv(x, y,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy + integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ real(psb_spk_) :: sdot character(len=20) :: name, ch_err name='psb_sdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -349,9 +356,9 @@ function psb_sdotv(x, y,desc_a, info,global) result(res) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_)& - & call psb_chkvect(m,ione,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -367,7 +374,7 @@ function psb_sdotv(x, y,desc_a, info,global) result(res) nr = desc_a%get_local_rows() if(nr > 0) then - res = sdot(int(nr,kind=psb_mpik_), x,1,y,1) + res = sdot(int(nr,kind=psb_mpk_), x,1,y,1) ! adjust res because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -448,16 +455,18 @@ subroutine psb_sdotvs(res, x, y,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, iy, iiy, jjy, i, m,nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i,nr, lldx, lldy + integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ real(psb_spk_) :: sdot character(len=20) :: name, ch_err name='psb_sdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -480,9 +489,9 @@ subroutine psb_sdotvs(res, x, y,desc_a, info,global) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ix,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ix,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,iy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,iy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -498,7 +507,7 @@ subroutine psb_sdotvs(res, x, y,desc_a, info,global) nr = desc_a%get_local_rows() if(nr > 0) then - res = sdot(int(nr,kind=psb_mpik_), x,1,y,1) + res = sdot(int(nr,kind=psb_mpk_), x,1,y,1) ! adjust res because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -579,16 +588,18 @@ subroutine psb_smdots(res, x, y, desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, j, k, nr, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ real(psb_spk_) :: sdot character(len=20) :: name, ch_err name='psb_smdots' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -612,14 +623,14 @@ subroutine psb_smdots(res, x, y, desc_a, info,global) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ix,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ix,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,lldy,iy,iy,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,lldy,iy,iy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -638,7 +649,7 @@ subroutine psb_smdots(res, x, y, desc_a, info,global) nr = desc_a%get_local_rows() if(nr > 0) then do j=1,k - res(j) = sdot(int(nr,kind=psb_mpik_),x(1:,j),1,y(1:,j),1) + res(j) = sdot(int(nr,kind=psb_mpk_),x(1:,j),1,y(1:,j),1) ! adjust res because overlapped elements are computed more than once end do do i=1,size(desc_a%ovrlap_elem,1) diff --git a/base/psblas/psb_snrm2.f90 b/base/psblas/psb_snrm2.f90 index f5ef9cb2f..d182a2cd3 100644 --- a/base/psblas/psb_snrm2.f90 +++ b/base/psblas/psb_snrm2.f90 @@ -60,15 +60,18 @@ function psb_snrm2(x, desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ real(psb_spk_) :: snrm2, dd character(len=20) :: name, ch_err name='psb_snrm2' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -94,7 +97,7 @@ function psb_snrm2(x, desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -109,7 +112,7 @@ function psb_snrm2(x, desc_a, info, jx,global) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = snrm2( int(ndim,kind=psb_mpik_), x(iix:,jjx), int(ione,kind=psb_mpik_) ) + res = snrm2( int(ndim,kind=psb_mpk_), x(iix:,jjx), int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) @@ -191,15 +194,18 @@ function psb_snrm2v(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx - logical :: global_ + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m real(psb_spk_) :: snrm2, dd + logical :: global_ character(len=20) :: name, ch_err name='psb_snrm2v' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -219,7 +225,7 @@ function psb_snrm2v(x, desc_a, info,global) result(res) jx=1 m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -234,7 +240,7 @@ function psb_snrm2v(x, desc_a, info,global) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = snrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) + res = snrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -274,13 +280,16 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ real(psb_spk_) :: snrm2, dd character(len=20) :: name, ch_err name='psb_snrm2v' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info=psb_success_ call psb_erractionsave(err_act) @@ -306,10 +315,10 @@ function psb_snrm2_vect(x, desc_a, info,global) result(res) end if ix = 1 - jx=1 - m = desc_a%get_global_rows() + jx = 1 + m = desc_a%get_global_rows() ldx = x%get_nrows() - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -408,15 +417,18 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ real(psb_spk_) :: nrm2, snrm2, dd character(len=20) :: name, ch_err name='psb_snrm2' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -437,7 +449,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) jx = 1 m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -452,7 +464,7 @@ subroutine psb_snrm2vs(res, x, desc_a, info,global) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = snrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) + res = snrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) diff --git a/base/psblas/psb_snrmi.f90 b/base/psblas/psb_snrmi.f90 index ecabd400b..07b88de2b 100644 --- a/base/psblas/psb_snrmi.f90 +++ b/base/psblas/psb_snrmi.f90 @@ -53,14 +53,17 @@ function psb_snrmi(a,desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iia, jja, ia, ja, mdim, ndim, m + & err_act, iia, jja, mdim, ndim + integer(psb_lpk_) :: m, n, ia, ja logical :: global_ character(len=20) :: name, ch_err name='psb_snrmi' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/psblas/psb_sspmm.f90 b/base/psblas/psb_sspmm.f90 index bb7d360c1..9fbb6d786 100644 --- a/base/psblas/psb_sspmm.f90 +++ b/base/psblas/psb_sspmm.f90 @@ -81,9 +81,9 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, ijx, ijy,& - & m, nrow, ncol, lldx, lldy, liwork, iiy, jjy,& - & i, ib, ib1, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, i, ib, ib1, ip, idx, ik + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik integer(psb_ipk_), parameter :: nb=4 real(psb_spk_), pointer :: xp(:,:), yp(:,:), iwork(:) real(psb_spk_), allocatable :: xvsave(:,:) @@ -93,9 +93,11 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_sspmm' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -132,10 +134,10 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& endif if (present(k)) then - ik = min(k,size(x,2)-ijx+1) - ik = min(ik,size(y,2)-ijy+1) + lik = min(k,size(x,2)-ijx+1) + lik = min(lik,size(y,2)-ijy+1) else - ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) endif if (present(trans)) then @@ -205,9 +207,9 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(n,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(n,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -224,16 +226,16 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& if (doswap_.and.(np>1)) then - ib1=min(nb,ik) + ib1=min(nb,lik) xp => x(iix:lldx,jjx:jjx+ib1-1) if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,szero,xp,desc_a,iwork,info) - blk: do i=1, ik, nb + blk: do i=1, lik, nb ib=ib1 - ib1 = max(0,min(nb,(ik)-(i-1+ib))) + ib1 = max(0,min(nb,(lik)-(i-1+ib))) xp => x(iix:lldx,jjx+i-1+ib:jjx+i-1+ib+ib1-1) if ((ib1 > 0).and.(doswap_)) & & call psi_swapdata(psb_swap_send_,ib1,& @@ -256,8 +258,8 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& else if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& - & ib1,szero,x(:,1:ik),desc_a,iwork,info) - if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + & ib1,szero,x(:,1:lik),desc_a,iwork,info) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:lik),beta,y(:,1:lik),info) end if if(info /= psb_success_) then info = psb_err_from_subroutine_non_ @@ -277,9 +279,9 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness - call psb_chkvect(m,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(n,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(n,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -300,12 +302,12 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& ! Why the average? because in this way they will contribute ! with a proper scale factor (1/np) to the overall product. ! - call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) + call psi_ovrl_save(x(:,1:lik),xvsave,desc_a,info) if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) - y(nrow+1:ncol,1:ik) = szero + y(nrow+1:ncol,1:lik) = szero if (info == psb_success_) & - & call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + & call psb_csmm(alpha,a,x(:,1:lik),beta,y(:,1:lik),info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info if (info /= psb_success_) then @@ -316,7 +318,9 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,& end if if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) - if (doswap_)then + if (doswap_)then + ik = lik ! This should not be an issue, we are expecting the values + ! to be small, within IPK call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,sone,y(:,1:ik),desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& @@ -428,9 +432,9 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & - & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, ib, ip, idx, ik + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy integer(psb_ipk_), parameter :: nb=4 real(psb_spk_), pointer :: iwork(:), xp(:), yp(:) real(psb_spk_), allocatable :: xvsave(:) @@ -440,9 +444,11 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_sspmv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -461,6 +467,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& iy = 1 jy = 1 ik = 1 + lik = 1 ib = 1 if (present(doswap)) then @@ -538,9 +545,9 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(n,ik,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(n,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -578,9 +585,9 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_)& - & call psb_chkvect(n,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(n,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -684,9 +691,9 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & - & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, ib, ip, idx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja integer(psb_ipk_), parameter :: nb=4 real(psb_spk_), pointer :: iwork(:), xp(:), yp(:) real(psb_spk_), allocatable :: xvsave(:) @@ -696,9 +703,11 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_sspmv' - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/psblas/psb_sspnrm1.f90 b/base/psblas/psb_sspnrm1.f90 index b8f2a4b73..391d60ee3 100644 --- a/base/psblas/psb_sspnrm1.f90 +++ b/base/psblas/psb_sspnrm1.f90 @@ -53,7 +53,8 @@ function psb_sspnrm1(a,desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, nr,nc,& - & err_act, n, iia, jja, ia, ja, mdim, ndim, m + & err_act, iia, jja, mdim, ndim + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja logical :: global_ character(len=20) :: name, ch_err real(psb_spk_), allocatable :: v(:) diff --git a/base/psblas/psb_sspsm.f90 b/base/psblas/psb_sspsm.f90 index d708b4aad..418b70402 100644 --- a/base/psblas/psb_sspsm.f90 +++ b/base/psblas/psb_sspsm.f90 @@ -93,10 +93,10 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& - & ix, iy, ik, ijx, ijy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& + & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik character :: lscale integer(psb_ipk_), parameter :: nb=4 real(psb_spk_),pointer :: iwork(:), xp(:,:), yp(:,:), id(:) @@ -105,9 +105,11 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_sspsm' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -137,10 +139,10 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& endif if (present(k)) then - ik = min(k,size(x,2)-ijx+1) - ik = min(ik,size(y,2)-ijy+1) + lik = min(k,size(x,2)-ijx+1) + lik = min(lik,size(y,2)-ijy+1) else - ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) endif if (present(choice)) then @@ -220,9 +222,9 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness if (info == psb_success_) & - & call psb_chkvect(m,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + & call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' @@ -245,6 +247,8 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if + ik = lik ! This should not be a problem. + ! We expect ik to be small, well within IPK ! Perform local triangular system solve xp => x(iix:lldx,jjx:jjx+ik-1) yp => y(iiy:lldy,jjy:jjy+ik-1) @@ -259,7 +263,6 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,& ! update overlap elements if (choice_ > 0) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & sone,yp,desc_a,iwork,info,data=psb_comm_ovr_) @@ -366,9 +369,9 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me, & - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& - & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& + & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy character :: lscale integer(psb_ipk_), parameter :: nb=4 @@ -378,9 +381,11 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_sspsv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -396,9 +401,10 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& ja = 1 ix = 1 iy = 1 + lik = 1 ik = 1 - jx= 1 - jy= 1 + jx = 1 + jy = 1 if (present(choice)) then choice_ = choice @@ -478,9 +484,9 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,& call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness if (info == psb_success_) & - & call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx) + & call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' @@ -571,9 +577,11 @@ subroutine psb_sspsv_vect(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_sspsv' - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/psblas/psb_zamax.f90 b/base/psblas/psb_zamax.f90 index e601725e2..21a82b393 100644 --- a/base/psblas/psb_zamax.f90 +++ b/base/psblas/psb_zamax.f90 @@ -58,14 +58,17 @@ function psb_zamax(x,desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zamax' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() @@ -93,7 +96,7 @@ function psb_zamax(x,desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -183,14 +186,17 @@ function psb_zamaxv (x,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zamaxv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -214,7 +220,7 @@ function psb_zamaxv (x,desc_a, info,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -264,14 +270,17 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m + & err_act, iix, jjx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zamaxv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -298,7 +307,7 @@ function psb_zamax_vect(x, desc_a, info,global) result(res) jx = 1 m = desc_a%get_global_rows() - call psb_chkvect(m,ione,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -391,14 +400,17 @@ subroutine psb_zamaxvs(res,x,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx + & err_act, iix, jjx, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zamaxvs' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt = desc_a%get_context() @@ -421,7 +433,7 @@ subroutine psb_zamaxvs(res,x,desc_a, info,global) m = desc_a%get_global_rows() ldx=size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -511,14 +523,17 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, ijx, m, ldx, i, k + & err_act, iix, jjx, ldx, i, k + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zmamaxs' - if (psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -545,7 +560,7 @@ subroutine psb_zmamaxs(res,x,desc_a, info,jx,global) m = desc_a%get_global_rows() k = min(size(x,2),size(res,1)) ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/psblas/psb_zasum.f90 b/base/psblas/psb_zasum.f90 index 9d49881bd..6bfd01caf 100644 --- a/base/psblas/psb_zasum.f90 +++ b/base/psblas/psb_zasum.f90 @@ -58,14 +58,17 @@ function psb_zasum (x,desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, & - & err_act, iix, jjx, ix, ijx, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zasum' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -93,7 +96,7 @@ function psb_zasum (x,desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -145,12 +148,15 @@ function psb_zasum_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, imax, i, idx, ndm + & err_act, iix, jjx, imax, i, idx, ndm + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zasumv' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info=psb_success_ call psb_erractionsave(err_act) @@ -180,7 +186,7 @@ function psb_zasum_vect(x, desc_a, info,global) result(res) jx = 1 m = desc_a%get_global_rows() - call psb_chkvect(m,ione,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -279,14 +285,17 @@ function psb_zasumv(x,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, jx, ix, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zasumv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -309,7 +318,7 @@ function psb_zasumv(x,desc_a, info,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -407,14 +416,17 @@ subroutine psb_zasumvs(res,x,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, jx, m, i, idx, ndm, ldx + & err_act, iix, jjx, i, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zasumvs' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -437,7 +449,7 @@ subroutine psb_zasumvs(res,x,desc_a, info,global) m = desc_a%get_global_rows() ldx = size(x,1) ! check vector correctness - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index 25ca548a2..273aa8823 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -43,7 +43,8 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, m, iiy, jjy + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err name='psb_zgeaxpby' @@ -77,14 +78,14 @@ subroutine psb_zaxpby_vect(alpha, x, beta, y,& m = desc_a%get_global_rows() ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ione,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,y%get_nrows(),iy,ione,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,y%get_nrows(),iy,lone,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' @@ -145,14 +146,16 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, ijx, ijy, m, iiy, in, jjy, & - & lldx, lldy + & err_act, iix, jjx, iiy, in, jjy, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -197,9 +200,9 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -291,15 +294,17 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ix, iy, m, iiy, jjy, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m character(len=20) :: name, ch_err logical, parameter :: debug=.false. name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -317,14 +322,14 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ione,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,lone,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 1' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,lldy,iy,ione,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,lldy,iy,lone,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect 2' diff --git a/base/psblas/psb_zdot.f90 b/base/psblas/psb_zdot.f90 index 9006a08b4..8f673c023 100644 --- a/base/psblas/psb_zdot.f90 +++ b/base/psblas/psb_zdot.f90 @@ -65,15 +65,18 @@ function psb_zdot_vect(x, y, desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr + & err_act, iix, jjx, iiy, jjy, i, nr + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ character(len=20) :: name, ch_err name='psb_zdot_vect' res = zzero - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -108,9 +111,9 @@ function psb_zdot_vect(x, y, desc_a,info,global) result(res) m = desc_a%get_global_rows() ! check vector correctness - call psb_chkvect(m,ione,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,x%get_nrows(),ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,y%get_nrows(),iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -167,16 +170,18 @@ function psb_zdot(x, y,desc_a, info, jx, jy,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, ijx, iy, ijy, iiy, jjy, i, m, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m complex(psb_dpk_) :: zdotc logical :: global_ character(len=20) :: name, ch_err name='psb_zdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() call psb_info(ictxt, me, np) @@ -217,9 +222,9 @@ function psb_zdot(x, y,desc_a, info, jx, jy,global) result(res) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -235,7 +240,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy,global) result(res) nr = desc_a%get_local_rows() if(nr > 0) then - res = zdotc(int(nr,kind=psb_mpik_), x(iix:,jjx),1,y(iiy:,jjy),1) + res = zdotc(int(nr,kind=psb_mpk_), x(iix:,jjx),1,y(iiy:,jjy),1) ! adjust dot_local because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -315,16 +320,18 @@ function psb_zdotv(x, y,desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, jx, iy, jy, iiy, jjy, i, m, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, nr, lldx, lldy + integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ complex(psb_dpk_) :: zdotc character(len=20) :: name, ch_err name='psb_zdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -349,9 +356,9 @@ function psb_zdotv(x, y,desc_a, info,global) result(res) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_)& - & call psb_chkvect(m,ione,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -367,7 +374,7 @@ function psb_zdotv(x, y,desc_a, info,global) result(res) nr = desc_a%get_local_rows() if(nr > 0) then - res = zdotc(int(nr,kind=psb_mpik_), x,1,y,1) + res = zdotc(int(nr,kind=psb_mpk_), x,1,y,1) ! adjust res because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -448,16 +455,18 @@ subroutine psb_zdotvs(res, x, y,desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, iy, iiy, jjy, i, m,nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i,nr, lldx, lldy + integer(psb_lpk_) :: ix, jx, iy, jy, m logical :: global_ complex(psb_dpk_) :: zdotc character(len=20) :: name, ch_err name='psb_zdot' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -480,9 +489,9 @@ subroutine psb_zdotvs(res, x, y,desc_a, info,global) lldx = size(x,1) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ix,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ix,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ione,lldy,iy,iy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lone,lldy,iy,iy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -498,7 +507,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info,global) nr = desc_a%get_local_rows() if(nr > 0) then - res = zdotc(int(nr,kind=psb_mpik_), x,1,y,1) + res = zdotc(int(nr,kind=psb_mpk_), x,1,y,1) ! adjust res because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -579,16 +588,18 @@ subroutine psb_zmdots(res, x, y, desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me, idx, ndm,& - & err_act, iix, jjx, ix, iy, iiy, jjy, i, m, j, k, nr, & - & lldx, lldy + & err_act, iix, jjx, iiy, jjy, i, j, k, nr, lldx, lldy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ complex(psb_dpk_) :: zdotc character(len=20) :: name, ch_err name='psb_zmdots' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -612,14 +623,14 @@ subroutine psb_zmdots(res, x, y, desc_a, info,global) lldy = size(y,1) ! check vector correctness - call psb_chkvect(m,ione,lldx,ix,ix,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,lldx,ix,ix,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - call psb_chkvect(m,ione,lldy,iy,iy,desc_a,info,iiy,jjy) + call psb_chkvect(m,lone,lldy,iy,iy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -638,7 +649,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info,global) nr = desc_a%get_local_rows() if(nr > 0) then do j=1,k - res(j) = zdotc(int(nr,kind=psb_mpik_),x(1:,j),1,y(1:,j),1) + res(j) = zdotc(int(nr,kind=psb_mpk_),x(1:,j),1,y(1:,j),1) ! adjust res because overlapped elements are computed more than once end do do i=1,size(desc_a%ovrlap_elem,1) diff --git a/base/psblas/psb_znrm2.f90 b/base/psblas/psb_znrm2.f90 index b3fd48dfc..1e1cac262 100644 --- a/base/psblas/psb_znrm2.f90 +++ b/base/psblas/psb_znrm2.f90 @@ -60,15 +60,18 @@ function psb_znrm2(x, desc_a, info, jx,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, ijx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m logical :: global_ real(psb_dpk_) :: dznrm2, dd character(len=20) :: name, ch_err name='psb_znrm2' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -94,7 +97,7 @@ function psb_znrm2(x, desc_a, info, jx,global) result(res) m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,ijx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -109,7 +112,7 @@ function psb_znrm2(x, desc_a, info, jx,global) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = dznrm2( int(ndim,kind=psb_mpik_), x(iix:,jjx), int(ione,kind=psb_mpik_) ) + res = dznrm2( int(ndim,kind=psb_mpk_), x(iix:,jjx), int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) @@ -191,15 +194,18 @@ function psb_znrm2v(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx - logical :: global_ + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m real(psb_dpk_) :: dznrm2, dd + logical :: global_ character(len=20) :: name, ch_err name='psb_znrm2v' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -219,7 +225,7 @@ function psb_znrm2v(x, desc_a, info,global) result(res) jx=1 m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -234,7 +240,7 @@ function psb_znrm2v(x, desc_a, info,global) result(res) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = dznrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) + res = dznrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) idx = desc_a%ovrlap_elem(i,1) @@ -274,13 +280,16 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ real(psb_dpk_) :: snrm2, dd character(len=20) :: name, ch_err name='psb_znrm2v' - if (psb_errstatus_fatal()) return + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info=psb_success_ call psb_erractionsave(err_act) @@ -306,10 +315,10 @@ function psb_znrm2_vect(x, desc_a, info,global) result(res) end if ix = 1 - jx=1 - m = desc_a%get_global_rows() + jx = 1 + m = desc_a%get_global_rows() ldx = x%get_nrows() - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -408,15 +417,18 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ndim, ix, jx, i, m, id, idx, ndm, ldx + & err_act, iix, jjx, ndim, i, id, idx, ndm, ldx + integer(psb_lpk_) :: ix, jx, iy, ijy, m logical :: global_ real(psb_dpk_) :: nrm2, dznrm2, dd character(len=20) :: name, ch_err name='psb_znrm2' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -437,7 +449,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) jx = 1 m = desc_a%get_global_rows() ldx = size(x,1) - call psb_chkvect(m,ione,ldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lone,ldx,ix,jx,desc_a,info,iix,jjx) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -452,7 +464,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info,global) if (desc_a%get_local_rows() > 0) then ndim = desc_a%get_local_rows() - res = dznrm2( int(ndim,kind=psb_mpik_), x, int(ione,kind=psb_mpik_) ) + res = dznrm2( int(ndim,kind=psb_mpk_), x, int(ione,kind=psb_mpk_) ) ! adjust because overlapped elements are computed more than once do i=1,size(desc_a%ovrlap_elem,1) diff --git a/base/psblas/psb_znrmi.f90 b/base/psblas/psb_znrmi.f90 index c0d169b96..9e0440ffa 100644 --- a/base/psblas/psb_znrmi.f90 +++ b/base/psblas/psb_znrmi.f90 @@ -53,14 +53,17 @@ function psb_znrmi(a,desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iia, jja, ia, ja, mdim, ndim, m + & err_act, iia, jja, mdim, ndim + integer(psb_lpk_) :: m, n, ia, ja logical :: global_ character(len=20) :: name, ch_err name='psb_znrmi' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/psblas/psb_zspmm.f90 b/base/psblas/psb_zspmm.f90 index a692822e8..b2470b2b5 100644 --- a/base/psblas/psb_zspmm.f90 +++ b/base/psblas/psb_zspmm.f90 @@ -81,9 +81,9 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, ijx, ijy,& - & m, nrow, ncol, lldx, lldy, liwork, iiy, jjy,& - & i, ib, ib1, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, i, ib, ib1, ip, idx, ik + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik integer(psb_ipk_), parameter :: nb=4 complex(psb_dpk_), pointer :: xp(:,:), yp(:,:), iwork(:) complex(psb_dpk_), allocatable :: xvsave(:,:) @@ -93,9 +93,11 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_zspmm' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -132,10 +134,10 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& endif if (present(k)) then - ik = min(k,size(x,2)-ijx+1) - ik = min(ik,size(y,2)-ijy+1) + lik = min(k,size(x,2)-ijx+1) + lik = min(lik,size(y,2)-ijy+1) else - ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) endif if (present(trans)) then @@ -205,9 +207,9 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(n,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(n,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -224,16 +226,16 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& if (doswap_.and.(np>1)) then - ib1=min(nb,ik) + ib1=min(nb,lik) xp => x(iix:lldx,jjx:jjx+ib1-1) if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& & ib1,zzero,xp,desc_a,iwork,info) - blk: do i=1, ik, nb + blk: do i=1, lik, nb ib=ib1 - ib1 = max(0,min(nb,(ik)-(i-1+ib))) + ib1 = max(0,min(nb,(lik)-(i-1+ib))) xp => x(iix:lldx,jjx+i-1+ib:jjx+i-1+ib+ib1-1) if ((ib1 > 0).and.(doswap_)) & & call psi_swapdata(psb_swap_send_,ib1,& @@ -256,8 +258,8 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& else if (doswap_)& & call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& - & ib1,zzero,x(:,1:ik),desc_a,iwork,info) - if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info) + & ib1,zzero,x(:,1:lik),desc_a,iwork,info) + if (info == psb_success_) call psb_csmm(alpha,a,x(:,1:lik),beta,y(:,1:lik),info) end if if(info /= psb_success_) then info = psb_err_from_subroutine_non_ @@ -277,9 +279,9 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! checking for vectors correctness - call psb_chkvect(m,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(n,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(n,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -300,12 +302,12 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& ! Why the average? because in this way they will contribute ! with a proper scale factor (1/np) to the overall product. ! - call psi_ovrl_save(x(:,1:ik),xvsave,desc_a,info) + call psi_ovrl_save(x(:,1:lik),xvsave,desc_a,info) if (info == psb_success_) call psi_ovrl_upd(x,desc_a,psb_avg_,info) - y(nrow+1:ncol,1:ik) = zzero + y(nrow+1:ncol,1:lik) = zzero if (info == psb_success_) & - & call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_) + & call psb_csmm(alpha,a,x(:,1:lik),beta,y(:,1:lik),info,trans=trans_) if (debug_level >= psb_debug_comp_) & & write(debug_unit,*) me,' ',trim(name),' csmm ', info if (info /= psb_success_) then @@ -316,7 +318,9 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,& end if if (info == psb_success_) call psi_ovrl_restore(x,xvsave,desc_a,info) - if (doswap_)then + if (doswap_)then + ik = lik ! This should not be an issue, we are expecting the values + ! to be small, within IPK call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & ik,zone,y(:,1:ik),desc_a,iwork,info) if (info == psb_success_) call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& @@ -428,9 +432,9 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & - & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, ib, ip, idx, ik + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy integer(psb_ipk_), parameter :: nb=4 complex(psb_dpk_), pointer :: iwork(:), xp(:), yp(:) complex(psb_dpk_), allocatable :: xvsave(:) @@ -440,9 +444,11 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_zspmv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -461,6 +467,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& iy = 1 jy = 1 ik = 1 + lik = 1 ib = 1 if (present(doswap)) then @@ -538,9 +545,9 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(n,ik,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(n,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -578,9 +585,9 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,& end if ! checking for vectors correctness - call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx) + call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_)& - & call psb_chkvect(n,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(n,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect' @@ -684,9 +691,9 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, n, iix, jjx, ia, ja, iia, jja, ix, iy, ik, & - & m, nrow, ncol, lldx, lldy, liwork, jx, jy, iiy, jjy,& - & ib, ip, idx + & err_act, iix, jjx, iia, jja, nrow, ncol, lldx, lldy, & + & liwork, iiy, jjy, ib, ip, idx + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja integer(psb_ipk_), parameter :: nb=4 complex(psb_dpk_), pointer :: iwork(:), xp(:), yp(:) complex(psb_dpk_), allocatable :: xvsave(:) @@ -696,9 +703,11 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,& integer(psb_ipk_) :: debug_level, debug_unit name='psb_zspmv' - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() diff --git a/base/psblas/psb_zspnrm1.f90 b/base/psblas/psb_zspnrm1.f90 index 95796ff52..3c292a74d 100644 --- a/base/psblas/psb_zspnrm1.f90 +++ b/base/psblas/psb_zspnrm1.f90 @@ -53,7 +53,8 @@ function psb_zspnrm1(a,desc_a,info,global) result(res) ! locals integer(psb_ipk_) :: ictxt, np, me, nr,nc,& - & err_act, n, iia, jja, ia, ja, mdim, ndim, m + & err_act, iia, jja, mdim, ndim + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja logical :: global_ character(len=20) :: name, ch_err real(psb_dpk_), allocatable :: v(:) diff --git a/base/psblas/psb_zspsm.f90 b/base/psblas/psb_zspsm.f90 index 085edc3dc..9e7f10645 100644 --- a/base/psblas/psb_zspsm.f90 +++ b/base/psblas/psb_zspsm.f90 @@ -93,10 +93,10 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me,& - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& - & ix, iy, ik, ijx, ijy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& + & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik character :: lscale integer(psb_ipk_), parameter :: nb=4 complex(psb_dpk_),pointer :: iwork(:), xp(:,:), yp(:,:), id(:) @@ -105,9 +105,11 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_zspsm' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -137,10 +139,10 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& endif if (present(k)) then - ik = min(k,size(x,2)-ijx+1) - ik = min(ik,size(y,2)-ijy+1) + lik = min(k,size(x,2)-ijx+1) + lik = min(lik,size(y,2)-ijy+1) else - ik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) + lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1) endif if (present(choice)) then @@ -220,9 +222,9 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness if (info == psb_success_) & - & call psb_chkvect(m,ik,lldx,ix,ijx,desc_a,info,iix,jjx) + & call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,ijy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' @@ -245,6 +247,8 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& goto 9999 end if + ik = lik ! This should not be a problem. + ! We expect ik to be small, well within IPK ! Perform local triangular system solve xp => x(iix:lldx,jjx:jjx+ik-1) yp => y(iiy:lldy,jjy:jjy+ik-1) @@ -259,7 +263,6 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,& ! update overlap elements if (choice_ > 0) then - call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,& & zone,yp,desc_a,iwork,info,data=psb_comm_ovr_) @@ -366,9 +369,9 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& ! locals integer(psb_ipk_) :: ictxt, np, me, & - & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,& - & ix, iy, ik, jx, jy, i, lld,& - & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,& + & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm + integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy character :: lscale integer(psb_ipk_), parameter :: nb=4 @@ -378,9 +381,11 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_zspsv' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() @@ -396,9 +401,10 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& ja = 1 ix = 1 iy = 1 + lik = 1 ik = 1 - jx= 1 - jy= 1 + jx = 1 + jy = 1 if (present(choice)) then choice_ = choice @@ -478,9 +484,9 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,& call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja) ! checking for vectors correctness if (info == psb_success_) & - & call psb_chkvect(m,ik,lldx,ix,jx,desc_a,info,iix,jjx) + & call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx) if (info == psb_success_) & - & call psb_chkvect(m,ik,lldy,iy,jy,desc_a,info,iiy,jjy) + & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy) if(info /= psb_success_) then info=psb_err_from_subroutine_ ch_err='psb_chkvect/mat' @@ -571,9 +577,11 @@ subroutine psb_zspsv_vect(alpha,a,x,beta,y,desc_a,info,& logical :: aliw name='psb_sspsv' - if (psb_errstatus_fatal()) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_context() diff --git a/base/serial/Makefile b/base/serial/Makefile index 7322ef2f3..1ce9156bb 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -1,14 +1,14 @@ include ../../Make.inc -FOBJS = psb_lsame.o psi_i_serial_impl.o \ +FOBJS = psb_lsame.o psi_m_serial_impl.o psi_e_serial_impl.o \ psi_s_serial_impl.o psi_d_serial_impl.o \ psi_c_serial_impl.o psi_z_serial_impl.o \ psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o \ psb_sspspmm.o psb_dspspmm.o psb_cspspmm.o psb_zspspmm.o \ psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \ psb_snumbmm.o psb_dnumbmm.o psb_cnumbmm.o psb_znumbmm.o \ - smmp.o \ + smmp.o lsmmp.o \ psb_sgeprt.o psb_dgeprt.o psb_cgeprt.o psb_zgeprt.o\ psb_spdot_srtd.o psb_aspxpby.o psb_spge_dot.o\ psb_sgelp.o psb_dgelp.o psb_cgelp.o psb_zgelp.o \ diff --git a/base/serial/impl/Makefile b/base/serial/impl/Makefile index efb036571..97662ba65 100644 --- a/base/serial/impl/Makefile +++ b/base/serial/impl/Makefile @@ -3,11 +3,22 @@ include ../../../Make.inc # # The object files # -BOBJS=psb_base_mat_impl.o psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o +BOBJS=psb_base_mat_impl.o \ + psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o +#\ + psb_s_lbase_mat_impl.o psb_d_lbase_mat_impl.o psb_c_lbase_mat_impl.o psb_z_lbase_mat_impl.o SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o +#\ + psb_s_lcoo_impl.o psb_s_lcsr_impl.o DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o +#\ + psb_d_lcoo_impl.o psb_d_lcsr_impl.o COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o +#\ + psb_c_lcoo_impl.o psb_c_lcsr_impl.o ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o +#\ + psb_z_lcoo_impl.o psb_z_lcsr_impl.o OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) diff --git a/base/serial/impl/psb_base_mat_impl.f90 b/base/serial/impl/psb_base_mat_impl.f90 index 6cc9ff168..faa919791 100644 --- a/base/serial/impl/psb_base_mat_impl.f90 +++ b/base/serial/impl/psb_base_mat_impl.f90 @@ -293,3 +293,299 @@ subroutine psb_base_trim(a) end subroutine psb_base_trim +function psb_lbase_get_nz_row(idx,a) result(res) + use psb_error_mod + use psb_base_mat_mod, psb_protect_name => psb_lbase_get_nz_row + implicit none + integer(psb_lpk_), intent(in) :: idx + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lbase_get_nz_row' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the lbase version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end function psb_lbase_get_nz_row + +function psb_lbase_get_nzeros(a) result(res) + use psb_base_mat_mod, psb_protect_name => psb_lbase_get_nzeros + use psb_error_mod + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lbase_get_nzeros' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end function psb_lbase_get_nzeros + +function psb_lbase_get_size(a) result(res) + use psb_base_mat_mod, psb_protect_name => psb_lbase_get_size + use psb_error_mod + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_) :: res + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_size' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + res = -1 + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end function psb_lbase_get_size + +subroutine psb_lbase_reinit(a,clear) + use psb_base_mat_mod, psb_protect_name => psb_lbase_reinit + use psb_error_mod + implicit none + + class(psb_lbase_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_err_missing_override_method_ + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_reinit + +subroutine psb_lbase_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_base_mat_mod, psb_protect_name => psb_lbase_sparse_print + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(in) :: iout + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_err_missing_override_method_ + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_sparse_print + +subroutine psb_lbase_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_base_mat_mod, psb_protect_name => psb_lbase_csgetptn + implicit none + + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_csgetptn + +subroutine psb_lbase_get_neigh(a,idx,neigh,n,info,lev) + use psb_base_mat_mod, psb_protect_name => psb_lbase_get_neigh + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + implicit none + class(psb_lbase_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: lev_, i, nl, ifl,ill,& + & nn, nidx,ntl,ma, n1 + integer(psb_lpk_), allocatable :: ia(:), ja(:) + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if(present(lev)) then + lev_ = lev + else + lev_=1 + end if + ! Turns out we can write get_neigh at this + ! level + n = 0 + ma = a%get_nrows() + call a%csget(idx,idx,n,ia,ja,info) + if (info == psb_success_) call psb_realloc(n,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + neigh(1:n) = ja(1:n) + ifl = 1 + ill = n + do nl = 2, lev_ + n1 = ill - ifl + 1 + call psb_ensure_size(ill+n1*n1,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + ntl = 0 + do i=ifl,ill + nidx=neigh(i) + if ((nidx /= idx).and.(nidx > 0).and.(nidx <= ma)) then + call a%csget(nidx,nidx,nn,ia,ja,info) + if (info == psb_success_) call psb_ensure_size(ill+ntl+nn,neigh,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) + ntl = ntl+nn + end if + end do + call psb_msort_unique(neigh(ill+1:ill+ntl),nn,dir=psb_sort_up_) + ifl = ill + 1 + ill = ill + nn + end do + call psb_msort_unique(neigh(1:ill),nn,dir=psb_sort_up_) + n = nn + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lbase_get_neigh + +subroutine psb_lbase_allocate_mnnz(m,n,a,nz) + use psb_base_mat_mod, psb_protect_name => psb_lbase_allocate_mnnz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_allocate_mnnz + +subroutine psb_lbase_reallocate_nz(nz,a) + use psb_base_mat_mod, psb_protect_name => psb_lbase_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_reallocate_nz + +subroutine psb_lbase_free(a) + use psb_base_mat_mod, psb_protect_name => psb_lbase_free + use psb_error_mod + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act + character(len=20) :: name='free' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + call psb_errpush(psb_err_missing_override_method_,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) +end subroutine psb_lbase_free + +subroutine psb_lbase_trim(a) + use psb_base_mat_mod, psb_protect_name => psb_lbase_trim + use psb_error_mod + implicit none + class(psb_lbase_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + ! + ! This is the base version. + ! The correct action is: do nothing. + ! Indeed, the more complicated the data structure, the + ! more likely this is the only possible course. + ! + + return + +end subroutine psb_lbase_trim + diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index c463746b6..e8cb8dfc3 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -50,8 +50,7 @@ subroutine psb_c_base_cp_to_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -75,8 +74,7 @@ subroutine psb_c_base_cp_from_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -101,8 +99,7 @@ subroutine psb_c_base_cp_to_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp @@ -144,8 +141,7 @@ subroutine psb_c_base_cp_from_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp @@ -190,8 +186,7 @@ subroutine psb_c_base_mv_to_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -228,8 +223,7 @@ subroutine psb_c_base_mv_from_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -266,8 +260,7 @@ subroutine psb_c_base_mv_to_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp @@ -297,8 +290,7 @@ subroutine psb_c_base_mv_from_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_c_coo_sparse_mat) :: tmp @@ -344,8 +336,7 @@ subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csput' logical, parameter :: debug=.false. @@ -372,8 +363,7 @@ subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csput_v' integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ @@ -423,8 +413,7 @@ subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -439,8 +428,6 @@ subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end subroutine psb_c_base_csgetrow - - ! ! Here we have the base implementation of getblk and clip: ! this is just based on the getrow. @@ -462,10 +449,9 @@ subroutine psb_c_base_csgetblk(imin,imax,a,b,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csget' - integer(psb_ipk_) :: jmin_, jmax_ + integer(psb_ipk_) :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. @@ -554,8 +540,7 @@ subroutine psb_c_base_csclip(a,b,info,& integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb character(len=20) :: name='csget' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -649,7 +634,6 @@ subroutine psb_c_base_tril(a,l,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_spk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -801,7 +785,6 @@ subroutine psb_c_base_triu(a,u,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_spk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -1000,8 +983,7 @@ subroutine psb_c_base_mold(a,b,info) class(psb_c_base_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='base_mold' logical, parameter :: debug=.false. @@ -1026,7 +1008,6 @@ subroutine psb_c_base_transp_2mat(a,b) type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='c_base_transp' call psb_erractionsave(err_act) @@ -1041,8 +1022,7 @@ subroutine psb_c_base_transp_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1)=ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1064,7 +1044,6 @@ subroutine psb_c_base_transc_2mat(a,b) type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='c_base_transc' call psb_erractionsave(err_act) @@ -1079,8 +1058,7 @@ subroutine psb_c_base_transc_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1) = ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1101,7 +1079,6 @@ subroutine psb_c_base_transp_1mat(a) type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='c_base_transp' call psb_erractionsave(err_act) @@ -1133,7 +1110,6 @@ subroutine psb_c_base_transc_1mat(a) type(psb_c_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='c_base_transc' call psb_erractionsave(err_act) @@ -1182,8 +1158,7 @@ subroutine psb_c_base_csmm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_csmm' logical, parameter :: debug=.false. @@ -1209,8 +1184,7 @@ subroutine psb_c_base_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_csmv' logical, parameter :: debug=.false. @@ -1237,8 +1211,7 @@ subroutine psb_c_base_inner_cssm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_inner_cssm' logical, parameter :: debug=.false. @@ -1264,8 +1237,7 @@ subroutine psb_c_base_inner_cssv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_inner_cssv' logical, parameter :: debug=.false. @@ -1296,7 +1268,6 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_spk_), allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act, nar,nac,nc, i character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_cssm' logical, parameter :: debug=.false. @@ -1313,14 +1284,12 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) nc = min(size(x,2), size(y,2)) if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1340,8 +1309,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1364,8 +1332,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1389,8 +1356,7 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1404,16 +1370,13 @@ subroutine psb_c_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - end subroutine psb_c_base_cssm @@ -1430,9 +1393,8 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_spk_), intent(in), optional :: d(:) complex(psb_spk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='c_cssm' logical, parameter :: debug=.false. @@ -1449,14 +1411,12 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1476,8 +1436,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1495,8 +1454,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1520,8 +1478,7 @@ subroutine psb_c_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1580,8 +1537,7 @@ subroutine psb_c_base_scals(d,a,info) complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_scals' logical, parameter :: debug=.false. @@ -1607,8 +1563,7 @@ subroutine psb_c_base_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_scal' logical, parameter :: debug=.false. @@ -1623,8 +1578,6 @@ subroutine psb_c_base_scal(d,a,info,side) end subroutine psb_c_base_scal - - function psb_c_base_maxval(a) result(res) use psb_error_mod use psb_const_mod @@ -1634,8 +1587,7 @@ function psb_c_base_maxval(a) result(res) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='maxval' logical, parameter :: debug=.false. @@ -1662,8 +1614,7 @@ function psb_c_base_csnmi(a) result(res) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' real(psb_spk_), allocatable :: vt(:) @@ -1701,8 +1652,7 @@ function psb_c_base_csnm1(a) result(res) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' real(psb_spk_), allocatable :: vt(:) @@ -1737,8 +1687,7 @@ subroutine psb_c_base_rowsum(d,a) class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1760,8 +1709,7 @@ subroutine psb_c_base_arwsum(d,a) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='arwsum' logical, parameter :: debug=.false. @@ -1783,8 +1731,7 @@ subroutine psb_c_base_colsum(d,a) class(psb_c_base_sparse_mat), intent(in) :: a complex(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1806,8 +1753,7 @@ subroutine psb_c_base_aclsum(d,a) class(psb_c_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1822,7 +1768,6 @@ subroutine psb_c_base_aclsum(d,a) end subroutine psb_c_base_aclsum - subroutine psb_c_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod @@ -1833,8 +1778,7 @@ subroutine psb_c_base_get_diag(a,d,info) complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -1900,9 +1844,8 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_spk_), allocatable :: tmp(:) class(psb_c_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='c_cssm' logical, parameter :: debug=.false. @@ -1919,14 +1862,12 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (x%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (y%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1949,8 +1890,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) @@ -1968,8 +1908,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1995,8 +1934,7 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -2034,8 +1972,7 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_inner_vect_sv' logical, parameter :: debug=.false. @@ -2059,3 +1996,2039 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) return end subroutine psb_c_base_inner_vect_sv + + +subroutine psb_c_base_cp_to_lcoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_cp_to_lcoo + +subroutine psb_c_base_cp_from_lcoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_lcoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_cp_from_lcoo + +subroutine psb_c_base_cp_to_lfmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: icoo + type(psb_lc_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%cp_to_lcoo(b,info) + class default + call a%cp_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call b%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_cp_to_lfmt + +subroutine psb_c_base_cp_from_lfmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_cp_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: icoo + type(psb_lc_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%cp_from_lcoo(b,info) + class default + call b%cp_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call a%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_cp_from_lfmt + + +subroutine psb_c_base_mv_to_lcoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_mv_to_lcoo + +subroutine psb_c_base_mv_from_lcoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lcoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_mv_from_lcoo + + +subroutine psb_c_base_mv_to_lfmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: icoo + type(psb_lc_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%mv_to_lcoo(b,info) + class default + call a%mv_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call b%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_mv_to_lfmt + +subroutine psb_c_base_mv_from_lfmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mv_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: icoo + type(psb_lc_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%mv_from_lcoo(b,info) + class default + call b%mv_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call a%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_base_mv_from_lfmt + +! +! +! lc implementation +! +! +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_lc_base_cp_to_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_cp_to_coo + +subroutine psb_lc_base_cp_from_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_cp_from_coo + + +subroutine psb_lc_base_cp_to_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_to_fmt + +subroutine psb_lc_base_cp_from_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_from_fmt + + +subroutine psb_lc_base_mv_to_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_to_coo + +subroutine psb_lc_base_mv_from_coo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_from_coo + + +subroutine psb_lc_base_mv_to_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_lc_base_mv_to_fmt + +subroutine psb_lc_base_mv_from_fmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lc_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_lc_base_mv_from_fmt + +subroutine psb_lc_base_clean_zeros(a, info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_clean_zeros + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + ! + type(psb_lc_coo_sparse_mat) :: tmpcoo + + call a%mv_to_coo(tmpcoo,info) + if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call a%mv_from_coo(tmpcoo,info) + +end subroutine psb_lc_base_clean_zeros + + +subroutine psb_lc_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_a + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_csput_a + +subroutine psb_lc_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csput_v + use psb_c_base_vect_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + if (a%is_dev()) call a%sync() + if (val%is_dev()) call val%sync() + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_csput_v + +subroutine psb_lc_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csgetrow + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_csgetrow + + + +! +! Here we have the base implementation of getblk and clip: +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_lc_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csgetblk + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout + character(len=20) :: name='csget' + integer(psb_lpk_) :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + if (present(rscale)) then + rscale_=rscale + else + rscale_=.false. + end if + if (present(cscale)) then + cscale_=cscale + else + cscale_=.false. + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if (append_.and.(rscale_.or.cscale_)) then + write(psb_err_unit,*) & + & 'lc_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' + end if + + if (rscale_) then + call b%set_nrows(imax-imin+1) + else + call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) + end if + + if (cscale_) then + call b%set_ncols(jmax_-jmin_+1) + else + call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) + end if + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_csgetblk + + +subroutine psb_lc_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csclip + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_csclip + + +! +! Here we have the base implementation of tril and triu +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_lc_base_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_tril + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + complex(psb_spk_), allocatable :: val(:) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + integer(psb_lpk_), parameter :: nbk=8 + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_, nbk + ibk = min(nbk,imax_-i+1) + call a%csget(i,i+ibk-1,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + if ((ja(k)-ia(k))<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = ia(k) + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = ia(k) + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end do + end do + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + do i=imin_,imax_ + k = min(jmax_,i+diag_) + call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& + & jmin=jmin_, jmax=k, append=.true., & + & nzin=nzin) + if (info /= psb_success_) goto 9999 + call l%set_nzeros(nzin+nzout) + nzin = nzin+nzout + end do + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_tril + +subroutine psb_lc_base_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_triu + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + complex(psb_spk_), allocatable :: val(:) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + integer(psb_lpk_), parameter :: nbk=8 + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_, nbk + ibk = min(nbk,imax_-i+1) + call a%csget(i,i+ibk-1,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + if ((ja(k)-ia(k))= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_triu + + + +subroutine psb_lc_base_clone(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_clone + use psb_error_mod + implicit none + + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b, stat=info) + end if + if (info /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + + ! Do not use SOURCE allocation: this makes sure that + ! memory allocated elsewhere is treated properly. + allocate(b,mold=a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%cp_from_fmt(a, info) + +end subroutine psb_lc_base_clone + +subroutine psb_lc_base_make_nonunit(a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_make_nonunit + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + type(psb_lc_coo_sparse_mat) :: tmp + + integer(psb_ipk_) :: info + integer(psb_lpk_) :: i, j, m, n, nz, mnm + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) + if (info /= 0) return + m = tmp%get_nrows() + n = tmp%get_ncols() + mnm = min(m,n) + nz = tmp%get_nzeros() + call tmp%reallocate(nz+mnm) + do i=1, mnm + tmp%val(nz+i) = cone + tmp%ia(nz+i) = i + tmp%ja(nz+i) = i + end do + call tmp%set_nzeros(nz+mnm) + call tmp%set_unit(.false.) + call tmp%fix(info) + if (info /= 0) & + & call a%mv_from_coo(tmp,info) + end if + +end subroutine psb_lc_base_make_nonunit + +subroutine psb_lc_base_mold(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mold + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_mold' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_mold + +subroutine psb_lc_base_transp_2mat(a,b) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lc_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_lc_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_transp_2mat + +subroutine psb_lc_base_transc_2mat(a,b) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transc_2mat + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lc_base_transc' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_lc_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lc_base_transc_2mat + +subroutine psb_lc_base_transp_1mat(a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_lc_base_sparse_mat), intent(inout) :: a + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lc_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_transp_1mat + +subroutine psb_lc_base_transc_1mat(a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_transc_1mat + implicit none + + class(psb_lc_base_sparse_mat), intent(inout) :: a + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lc_base_transc' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_transc_1mat + +subroutine psb_lc_base_scals(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scals + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_scals' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_scals + +subroutine psb_lc_base_scal(d,a,info,side) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_scal + use psb_error_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_scal + +function psb_lc_base_maxval(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_maxval + + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + res = szero + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end function psb_lc_base_maxval + +function psb_lc_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csnmi + + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + real(psb_spk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = szero + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%arwsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_base_csnmi + +function psb_lc_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_csnm1 + + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + real(psb_spk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = szero + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%aclsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_base_csnm1 + +subroutine psb_lc_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_rowsum + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_rowsum + +subroutine psb_lc_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_arwsum + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_arwsum + +subroutine psb_lc_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_colsum + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_colsum + +subroutine psb_lc_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_aclsum + class(psb_lc_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_aclsum + +subroutine psb_lc_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_get_diag + + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lc_base_get_diag + + + +subroutine psb_lc_base_cp_to_icoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_to_icoo + +subroutine psb_lc_base_cp_from_icoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_from_icoo + + +subroutine psb_lc_base_cp_to_ifmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: icoo + type(psb_lc_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_c_coo_sparse_mat) + call a%cp_to_icoo(b,info) + class default + call a%cp_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call b%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_to_ifmt + +subroutine psb_lc_base_cp_from_ifmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_cp_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: icoo + type(psb_lc_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_c_coo_sparse_mat) + call a%cp_from_icoo(b,info) + class default + call b%cp_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call a%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_cp_from_ifmt + + +subroutine psb_lc_base_mv_to_icoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_icoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_to_icoo + +subroutine psb_lc_base_mv_from_icoo(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_from_icoo + + +subroutine psb_lc_base_mv_to_ifmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: icoo + type(psb_lc_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_c_coo_sparse_mat) + call a%mv_to_icoo(b,info) + class default + call a%mv_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call b%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_to_ifmt + +subroutine psb_lc_base_mv_from_ifmt(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_base_mv_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lc_base_sparse_mat), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_c_coo_sparse_mat) :: icoo + type(psb_lc_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_c_coo_sparse_mat) + call a%mv_from_icoo(b,info) + class default + call b%mv_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call a%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_base_mv_from_ifmt + + diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index 695e35830..c2b27cc88 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -29,7 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - subroutine psb_c_coo_get_diag(a,d,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_get_diag use psb_error_mod @@ -39,8 +38,7 @@ subroutine psb_c_coo_get_diag(a,d,info) complex(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -51,8 +49,7 @@ subroutine psb_c_coo_get_diag(a,d,info) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -88,8 +85,7 @@ subroutine psb_c_coo_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ logical :: left @@ -114,8 +110,7 @@ subroutine psb_c_coo_scal(d,a,info,side) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -127,8 +122,7 @@ subroutine psb_c_coo_scal(d,a,info,side) m = a%get_ncols() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -158,8 +152,7 @@ subroutine psb_c_coo_scals(d,a,info) complex(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -193,15 +186,16 @@ subroutine psb_c_coo_reallocate_nz(nz,a) implicit none integer(psb_ipk_), intent(in) :: nz class(psb_c_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='c_coo_reallocate_nz' logical, parameter :: debug=.false. call psb_erractionsave(err_act) nz_ = max(nz,ione) - call psb_realloc(nz_,a%ia,a%ja,a%val,info) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -224,8 +218,7 @@ subroutine psb_c_coo_mold(a,b,info) class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. @@ -259,8 +252,7 @@ subroutine psb_c_coo_reinit(a,clear) class(psb_c_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -306,8 +298,7 @@ subroutine psb_c_coo_trim(a) use psb_error_mod implicit none class(psb_c_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -363,8 +354,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) integer(psb_ipk_), intent(in) :: m,n class(psb_c_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='allocate_mnz' logical, parameter :: debug=.false. @@ -372,14 +362,12 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) info = psb_success_ if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif if (present(nz)) then @@ -389,8 +377,7 @@ subroutine psb_c_coo_allocate_mnnz(m,n,a,nz) end if if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 endif if (info == psb_success_) call psb_realloc(nz_,a%ia,info) @@ -431,13 +418,12 @@ subroutine psb_c_coo_print(iout,a,iv,head,ivr,ivc) character(len=*), optional :: head integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='complex' - character(len=80) :: frmtv + character(len=80) :: frmtv integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' @@ -507,7 +493,7 @@ function psb_c_coo_get_nz_row(idx,a) result(res) nza = a%get_nzeros() if (a%is_by_rows()) then ! In this case we can do a binary search. - ip = psb_ibsrch(idx,nza,a%ia) + ip = psb_bsrch(idx,nza,a%ia) if (ip /= -1) return jp = ip do @@ -560,8 +546,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) complex(psb_spk_) :: acc complex(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_csmm' logical, parameter :: debug=.false. @@ -591,14 +576,12 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -916,8 +899,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) complex(psb_spk_) :: acc complex(psb_spk_), allocatable :: tmp(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_cssv_impl' logical, parameter :: debug=.false. @@ -941,14 +923,12 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if if (.not. (a%is_triangle())) then @@ -1260,8 +1240,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc complex(psb_spk_) :: acc logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_csmv_impl' logical, parameter :: debug=.false. @@ -1295,16 +1274,15 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if + nnz = a%get_nzeros() if (alpha == czero) then @@ -1448,15 +1426,14 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) class(psb_c_coo_sparse_mat), intent(in) :: a complex(psb_spk_), intent(in) :: alpha, beta, x(:,:) complex(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans character :: trans_ integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc complex(psb_spk_), allocatable :: acc(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_csmm_impl' logical, parameter :: debug=.false. @@ -1492,14 +1469,12 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -1652,8 +1627,7 @@ function psb_c_coo_maxval(a) result(res) class(psb_c_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info character(len=20) :: name='c_coo_maxval' logical, parameter :: debug=.false. @@ -1684,7 +1658,6 @@ function psb_c_coo_csnmi(a) result(res) real(psb_spk_), allocatable :: vt(:) logical :: tra, is_unit integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_coo_csnmi' logical, parameter :: debug=.false. @@ -1746,7 +1719,6 @@ function psb_c_coo_csnm1(a) result(res) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_coo_csnm1' logical, parameter :: debug=.false. @@ -1785,7 +1757,6 @@ subroutine psb_c_coo_rowsum(d,a) complex(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1793,10 +1764,10 @@ subroutine psb_c_coo_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() + if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1834,7 +1805,6 @@ subroutine psb_c_coo_arwsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1844,8 +1814,7 @@ subroutine psb_c_coo_arwsum(d,a) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1882,7 +1851,6 @@ subroutine psb_c_coo_colsum(d,a) complex(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1892,8 +1860,7 @@ subroutine psb_c_coo_colsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if @@ -1931,7 +1898,6 @@ subroutine psb_c_coo_aclsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1941,11 +1907,11 @@ subroutine psb_c_coo_aclsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if + if (a%is_unit()) then d = sone else @@ -1969,7 +1935,6 @@ subroutine psb_c_coo_aclsum(d,a) end subroutine psb_c_coo_aclsum - ! == ================================== ! ! @@ -2004,8 +1969,7 @@ subroutine psb_c_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, intent(in), optional :: rscale,cscale logical :: append_, rscale_, cscale_ - integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2121,7 +2085,7 @@ contains if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do - ip = psb_ibsrch(irw,nza,a%ia) + ip = psb_bsrch(irw,nza,a%ia) if (ip /= -1) exit irw = irw + 1 if (irw > imax) then @@ -2146,7 +2110,7 @@ contains end if do - jp = psb_ibsrch(lrw,nza,a%ia) + jp = psb_bsrch(lrw,nza,a%ia) if (jp /= -1) exit lrw = lrw - 1 if (irw > lrw) then @@ -2280,7 +2244,6 @@ subroutine psb_c_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_, chksz_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2404,7 +2367,7 @@ contains if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do - ip = psb_ibsrch(irw,nza,a%ia) + ip = psb_bsrch(irw,nza,a%ia) if (ip /= -1) exit irw = irw + 1 if (irw > imax) then @@ -2429,7 +2392,7 @@ contains end if do - jp = psb_ibsrch(lrw,nza,a%ia) + jp = psb_bsrch(lrw,nza,a%ia) if (jp /= -1) exit lrw = lrw - 1 if (irw > lrw) then @@ -2566,12 +2529,11 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='c_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2580,27 +2542,23 @@ subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (nz < 0) then info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 end if @@ -2760,7 +2718,7 @@ contains if ((ir > 0).and.(ir <= nr)) then ic = gtl(ic) if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2778,7 +2736,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2802,7 +2760,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2820,7 +2778,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2853,7 +2811,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2871,7 +2829,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2890,7 +2848,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2908,7 +2866,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2941,8 +2899,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -2984,8 +2941,7 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3031,8 +2987,7 @@ subroutine psb_c_cp_coo_to_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3064,8 +3019,7 @@ subroutine psb_c_cp_coo_from_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3099,8 +3053,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3142,8 +3095,7 @@ subroutine psb_c_mv_coo_from_coo(a,b,info) class(psb_c_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3187,8 +3139,7 @@ subroutine psb_c_mv_coo_to_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3220,8 +3171,7 @@ subroutine psb_c_mv_coo_from_fmt(a,b,info) class(psb_c_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3255,8 +3205,7 @@ subroutine psb_c_coo_cp_from(a,b) type(psb_c_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. @@ -3286,8 +3235,7 @@ subroutine psb_c_coo_mv_from(a,b) type(psb_c_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='mv_from' logical, parameter :: debug=.false. @@ -3324,7 +3272,6 @@ subroutine psb_c_fix_coo(a,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca integer(psb_ipk_) :: i,j, irw, icl, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' info = psb_success_ @@ -3375,6 +3322,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_c_base_mat_mod, psb_protect_name => psb_c_fix_coo_inner use psb_string_mod use psb_ip_reord_mod + use psb_sort_mod implicit none integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl @@ -3388,7 +3336,6 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_ integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers @@ -3461,7 +3408,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ja(i:imx),ix2,iret) + call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3572,7 +3519,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,jas(i:imx),ix2,iret) + call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3665,7 +3612,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! If we did not have enough memory for buffers, ! let's try in place. ! - call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret) + call psi_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3677,7 +3624,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret) + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3784,7 +3731,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ia(i:imx),ix2,iret) + call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3893,7 +3840,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ias(i:imx),ix2,iret) + call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3980,7 +3927,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret) + call psi_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3991,7 +3938,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret) + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -4082,3 +4029,3102 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_c_fix_coo_inner + +subroutine psb_c_cp_coo_to_lcoo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_to_lcoo + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lbase_sparse_mat = a%psb_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_c_cp_coo_to_lcoo + +subroutine psb_c_cp_coo_from_lcoo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_c_cp_coo_from_lcoo + implicit none + class(psb_c_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_base_sparse_mat = b%psb_lbase_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_c_cp_coo_from_lcoo + + +! +! +! lc coo impl +! +! + +subroutine psb_lc_coo_get_diag(a,d,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + if (a%is_unit()) then + d(1:mnm) = cone + else + d(1:mnm) = czero + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_get_diag + +subroutine psb_lc_coo_scal(d,a,info,side) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scal + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_scal + + +subroutine psb_lc_coo_scals(d,a,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_scals + + +function psb_lc_coo_maxval(a) result(res) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_maxval + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + character(len=20) :: name='c_coo_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + res = sone + else + res = szero + end if + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if + +end function psb_lc_coo_maxval + +function psb_lc_coo_csnmi(a) result(res) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnmi + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_coo_csnmi' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + is_unit = a%is_unit() + if (a%is_by_rows()) then + i = 1 + j = i + res = szero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + if (is_unit) then + acc = sone + else + acc = szero + end if + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + if (is_unit) then + vt = sone + else + vt = szero + end if + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_lc_coo_csnmi + + +function psb_lc_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csnm1 + + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_coo_csnm1' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + if (a%is_unit()) then + vt = sone + else + vt = szero + end if + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_lc_coo_csnm1 + +subroutine psb_lc_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_rowsum + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = cone + else + d = czero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_rowsum + +subroutine psb_lc_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_arwsum + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_arwsum + +subroutine psb_lc_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_colsum + class(psb_lc_coo_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + if (a%is_unit()) then + d = cone + else + d = czero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_colsum + +subroutine psb_lc_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_aclsum + class(psb_lc_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_aclsum + +subroutine psb_lc_coo_reallocate_nz(nz,a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='lc_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + nz_ = max(nz,ione) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_reallocate_nz + +subroutine psb_lc_coo_mold(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mold + use psb_error_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='coo_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lc_coo_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_mold + +subroutine psb_lc_coo_reinit(a,clear) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_reinit + use psb_error_mod + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_dev()) call a%sync() + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_host() + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_reinit + + + +subroutine psb_lc_coo_trim(a) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_trim + +subroutine psb_lc_coo_clean_zeros(a, info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_clean_zeros + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: info + ! + integer(psb_lpk_) :: i,j,k, nzin + + info = 0 + nzin = a%get_nzeros() + j = 0 + do i=1, nzin + if (a%val(i) /= czero) then + j = j + 1 + a%val(j) = a%val(i) + a%ia(j) = a%ia(i) + a%ja(j) = a%ja(i) + end if + end do + call a%set_nzeros(j) + call a%trim() +end subroutine psb_lc_coo_clean_zeros + + + +subroutine psb_lc_coo_allocate_mnnz(m,n,a,nz) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,izero/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(lzero) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + ! An empty matrix is sorted! + call a%set_sorted(.true.) + call a%set_host() + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_allocate_mnnz + + + +subroutine psb_lc_coo_print(iout,a,iv,head,ivr,ivc) + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_print + use psb_string_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_coo_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_lc_coo_print + + + + +function psb_lc_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_get_nz_row + implicit none + + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k + integer(psb_ipk_) :: inza + + if (a%is_dev()) call a%sync() + res = 0 + nza = a%get_nzeros() + if (a%is_by_rows()) then + ! In this case we can do a binary search. + inza = nza + ip = psb_bsrch(idx,inza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_lc_coo_get_nz_row + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_lc_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csgetptn + implicit none + + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_lc_coo_csgetptn + + +! +! NZ is the number of non-zeros on output. +! The output is guaranteed to be sorted +! +subroutine psb_lc_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csgetrow + implicit none + + class(psb_lc_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = iren(a%ia(i)) + ja(nzin_+nz) = iren(a%ja(i)) + end if + enddo + call psb_lc_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = a%ia(i) + ja(nzin_+nz) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + end if + call psb_lc_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + end if + + end subroutine coo_getrow + +end subroutine psb_lc_coo_csgetrow + + +subroutine psb_lc_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_csput_a + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_coo_csput_a_impl' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (nz < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + endif + isza = a%get_size() + if (isza < (nza+nz)) then + info = psb_err_alloc_dealloc_; call psb_errpush(info,name) + goto 9999 + end if + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + if (a%is_dev()) call a%sync() + + call lc_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_), intent(inout) :: aspk(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine lc_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nnz,dupl,ng, nr + integer(psb_ipk_) :: debug_level, debug_unit, innz, nc + character(len=20) :: name='lc_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + innz = nnz + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + endif + else + info = max(info,1) + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine lc_coo_srch_upd + +end subroutine psb_lc_coo_csput_a + + +subroutine psb_lc_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_coo + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_to_coo + +subroutine psb_lc_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_coo + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_from_coo + + +subroutine psb_lc_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_fmt + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_to_fmt + +subroutine psb_lc_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_fmt + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_from_fmt + + +subroutine psb_lc_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_to_coo + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + call b%set_nzeros(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call b%set_host() + call a%free() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_mv_coo_to_coo + +subroutine psb_lc_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_from_coo + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + call a%set_nzeros(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_mv_coo_from_coo + + +subroutine psb_lc_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_to_fmt + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_mv_coo_to_fmt + +subroutine psb_lc_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_mv_coo_from_fmt + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_mv_coo_from_fmt + +subroutine psb_lc_coo_cp_from(a,b) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_cp_from + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + type(psb_lc_coo_sparse_mat), intent(in) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_cp_from + +subroutine psb_lc_coo_mv_from(a,b) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_coo_mv_from + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + type(psb_lc_coo_sparse_mat), intent(inout) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_coo_mv_from + + + +subroutine psb_lc_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_fix_coo + implicit none + + class(psb_lc_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + integer(psb_lpk_), allocatable :: iaux(:) + !locals + integer(psb_lpk_) :: nza, nzl,iret, nra, nca + integer(psb_lpk_) :: i,j, irw, icl + integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + if (a%is_dev()) call a%sync() + + nra = a%get_nrows() + nca = a%get_ncols() + nza = a%get_nzeros() + if (nza >= 2) then + dupl_ = a%get_dupl() + call psb_lc_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + else + i = nza + end if + call a%set_sort_status(idir_) + call a%set_nzeros(i) + call a%set_asb() + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_fix_coo + + + +subroutine psb_lc_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + use psb_sort_mod + implicit none + + integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + complex(psb_spk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + !locals + integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) + complex(psb_spk_), allocatable :: vs(:) + integer(psb_lpk_) :: nza + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin + integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + logical :: srt_inp, use_buffers + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + + + if (nzin < 2) then + call psb_erractionrestore(err_act) + return + end if + + dupl_ = dupl + + + + allocate(iaux(max(nr,nc,nzin)+2),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) + use_buffers = (info == 0) + + select case(idir_) + + case(psb_row_major_) + ! Row major order + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + iaux(:) = 0 + iaux(ia(1)) = iaux(ia(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ia(i) < 1).or.(ia(i)> nr)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ia(i)) = iaux(ia(i)) + 1 + srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) + end do + else + use_buffers=.false. + end if + end if + ! Check again use_buffers. + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major + ! we can do it row-by-row here. + k = 0 + i = 1 + do j=1, nr + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ja(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already row-major + ! we have to sort all + + ip = iaux(1) + iaux(1) = 0 + do i=2, nr + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nr+1) = ip + + do i=1,nzin + irw = ia(i) + ip = iaux(irw) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(irw) = ip + end do + k = 0 + i = 1 + do j=1, nr + + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,jas(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + ! + ! If we did not have enough memory for buffers, + ! let's try in place. + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + endif + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + + case(psb_col_major_) + + if (use_buffers) then + iaux(:) = 0 + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + iaux(ja(1)) = iaux(ja(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ja(i) < 1).or.(ja(i)> nc)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ja(i)) = iaux(ja(i)) + 1 + srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) + end do + else + use_buffers=.false. + end if + end if + !use_buffers=use_buffers.and.srt_inp + ! Check again use_buffers. + if (use_buffers) then + + if (srt_inp) then + ! If input was already col-major + ! we can do it col-by-col here. + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ia(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already col-major + ! we have to sort all + ip = iaux(1) + iaux(1) = 0 + do i=2, nc + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nc+1) = ip + + do i=1,nzin + icl = ja(i) + ip = iaux(icl) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(icl) = ip + end do + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ias(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + end if + + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_fix_coo_inner + + +subroutine psb_lc_cp_coo_to_icoo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_to_icoo + implicit none + class(psb_lc_coo_sparse_mat), intent(in) :: a + class(psb_c_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_base_sparse_mat = a%psb_lbase_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_to_icoo + +subroutine psb_lc_cp_coo_from_icoo(a,b,info) + use psb_error_mod + use psb_c_base_mat_mod, psb_protect_name => psb_lc_cp_coo_from_icoo + implicit none + class(psb_lc_coo_sparse_mat), intent(inout) :: a + class(psb_c_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lbase_sparse_mat = b%psb_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index 4e76fe2b8..ed80519d9 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -2030,7 +2030,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2059,7 +2059,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2098,7 +2098,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2122,7 +2122,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2951,3 +2951,1901 @@ contains end subroutine csc_spspmm end subroutine psb_ccscspspmm + + + +subroutine psb_lc_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_get_diag + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = cone + else + do i=1, mnm + d(i) = czero + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + endif + do i=mnm+1,size(d) + d(i) = czero + end do + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_get_diag + + +subroutine psb_lc_csc_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_scal + use psb_string_mod + implicit none + class(psb_lc_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, n + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act,ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + if (a%is_unit()) then + call a%make_nonunit() + end if + + left = (side_ == 'L') + + if (left) then + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, a%get_nzeros() + a%val(i) = a%val(i) * d(a%ia(i)) + enddo + else + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do j=1, n + do i = a%icp(j), a%icp(j+1) -1 + a%val(i) = a%val(i) * d(j) + end do + enddo + end if + call a%set_host() + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_scal + + +subroutine psb_lc_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_scals + implicit none + class(psb_lc_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act,ierr(5) + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_scals + + +function psb_lc_csc_maxval(a) result(res) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_maxval + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: nnz + character(len=20) :: name='lc_csc_maxval' + logical, parameter :: debug=.false. + + + if (a%is_unit()) then + res = sone + else + res = szero + end if + if (a%is_dev()) call a%sync() + + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_lc_csc_maxval + +function psb_lc_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csnm1 + + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_csc_csnm1' + logical, parameter :: debug=.false. + + + res = szero + if (a%is_dev()) call a%sync() + m = a%get_nrows() + n = a%get_ncols() + is_unit = a%is_unit() + do j=1, n + if (is_unit) then + acc = sone + else + acc = szero + end if + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_lc_csc_csnm1 + +subroutine psb_lc_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_colsum + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = cone + else + d(i) = czero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_colsum + +subroutine psb_lc_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_aclsum + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_lpk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = sone + else + d(i) = szero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, a%get_ncols() + d(i) = d(i) + sone + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_aclsum + +subroutine psb_lc_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_rowsum + class(psb_lc_csc_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = cone + else + d = czero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_rowsum + +subroutine psb_lc_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_arwsum + class(psb_lc_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_arwsum + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_lc_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csgetptn + implicit none + + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + + end subroutine lcsc_getptn + +end subroutine psb_lc_csc_csgetptn + + + + +subroutine psb_lc_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csgetrow + implicit none + + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + call psb_ensure_size(int(1.25*nzin_)+ione,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + call psb_ensure_size(int(1.25*nzin_)+ione,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + end subroutine lcsc_getrow + +end subroutine psb_lc_csc_csgetrow + + + +subroutine psb_lc_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csput_a + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5) + character(len=20) :: name='lc_csc_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + ierr(1)=1 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=3 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=4 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_lc_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_lc_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng, nar, nac + integer(psb_ipk_) :: debug_level, debug_unit, inr + character(len=20) :: name='lc_csc_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nar = a%get_nrows() + nac = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_lc_csc_srch_upd + +end subroutine psb_lc_csc_csput_a + + +subroutine psb_lc_cp_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_cp_csc_from_coo + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! We need to make a copy because mv_from will have to + ! sort in column-major order. + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_lc_cp_csc_from_coo + + + +subroutine psb_lc_cp_csc_to_coo(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_cp_csc_to_coo + implicit none + + class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ia(j) = a%ia(j) + b%ja(j) = i + b%val(j) = a%val(j) + end do + end do + + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_lc_cp_csc_to_coo + + +subroutine psb_lc_mv_csc_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_mv_csc_to_coo + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ia,b%ia) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ja,info) + if (info /= psb_success_) return + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ja(j) = i + end do + end do + call a%free() + call b%fix(info) + +end subroutine psb_lc_mv_csc_to_coo + + +subroutine psb_lc_mv_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_mv_csc_from_coo + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, i,j,k,ip,irw, nc, nrl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name='lc_mv_csc_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info, idir=psb_col_major_) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ja,itemp) + call move_alloc(b%ia,a%ia) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%icp,info) + call b%free() + + a%icp(:) = 0 + do k=1,nza + i = itemp(k) + a%icp(i) = a%icp(i) + 1 + end do + ip = 1 + do i=1,nc + nrl = a%icp(i) + a%icp(i) = ip + ip = ip + nrl + end do + a%icp(nc+1) = ip + call a%set_host() + + +end subroutine psb_lc_mv_csc_from_coo + + +subroutine psb_lc_mv_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_mv_csc_to_fmt + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_lc_csc_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call move_alloc(a%icp, b%icp) + call move_alloc(a%ia, b%ia) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lc_mv_csc_to_fmt +!!$ + +subroutine psb_lc_cp_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_cp_csc_to_fmt + implicit none + + class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_lc_csc_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + nc = a%get_ncols() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lc_cp_csc_to_fmt + + +subroutine psb_lc_mv_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_mv_csc_from_fmt + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_lc_csc_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + call a%set_host() + +end subroutine psb_lc_mv_csc_from_fmt + + + +subroutine psb_lc_cp_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_cp_csc_from_fmt + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_lc_csc_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + nc = b%get_ncols() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + call a%set_host() + +end subroutine psb_lc_cp_csc_from_fmt + + +subroutine psb_lc_csc_mold(a,b,info) + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_mold + use psb_error_mod + implicit none + class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csc_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lc_csc_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_mold + +subroutine psb_lc_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_reallocate_nz + implicit none + integer(psb_ipk_), intent(in) :: nz + class(psb_lc_csc_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='lc_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ia,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,& + & a%get_ncols()+1), a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_reallocate_nz + + + +subroutine psb_lc_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_csgetblk + implicit none + + class(psb_lc_csc_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_csgetblk + +subroutine psb_lc_csc_reinit(a,clear) + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_reinit + implicit none + + class(psb_lc_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_reinit + +subroutine psb_lc_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_trim + implicit none + class(psb_lc_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, n + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + n = a%get_ncols() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_trim + +subroutine psb_lc_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csc_allocate_mnnz + +subroutine psb_lc_csc_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_c_csc_mat_mod, psb_protect_name => psb_lc_csc_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='lc_csc_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_lc_csc_print + +subroutine psb_lccscspspmm(a,b,c,info) + use psb_c_mat_mod + use psb_serial_mod, psb_protect_name => psb_lccscspspmm + + implicit none + + class(psb_lc_csc_sparse_mat), intent(in) :: a,b + type(psb_lc_csc_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_cscspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + + call csc_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csc_spspmm(a,b,c,info) + implicit none + type(psb_lc_csc_sparse_mat), intent(in) :: a,b + type(psb_lc_csc_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: icol(:), idxs(:), iaux(:) + complex(psb_spk_), allocatable :: col(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + complex(psb_spk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ia)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,col,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,icol,info) + if (info /= 0) return + col = dzero + icol = 0 + nzc = 1 + do j = 1,nb + c%icp(j) = nzc + nrc = 0 + do k = b%icp(j), b%icp(j+1)-1 + icl = b%ia(k) + cfb = b%val(k) + irwsz = a%icp(icl+1)-a%icp(icl) + do i = a%icp(icl),a%icp(icl+1)-1 + irw = a%ia(i) + if (icol(irw) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ia,info) + if (info /= 0) return + end if + call psb_msort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) + col(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%icp(nb+1) = nzc + + end subroutine csc_spspmm + +end subroutine psb_lccscspspmm diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index bb0d53097..66ca5f756 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -1018,7 +1018,6 @@ subroutine psb_c_csr_cssm(alpha,a,x,beta,y,info,trans) complex(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_csr_cssm' logical, parameter :: debug=.false. @@ -1269,8 +1268,8 @@ function psb_c_csr_maxval(a) result(res) class(psb_c_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: info character(len=20) :: name='c_csr_maxval' logical, parameter :: debug=.false. @@ -1295,7 +1294,6 @@ function psb_c_csr_csnmi(a) result(res) real(psb_spk_) :: acc logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_csnmi' logical, parameter :: debug=.false. @@ -1304,7 +1302,7 @@ function psb_c_csr_csnmi(a) result(res) if (a%is_dev()) call a%sync() do i = 1, a%get_nrows() - acc = dzero + acc = szero do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do @@ -1655,7 +1653,6 @@ subroutine psb_c_csr_scals(d,a,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -1704,7 +1701,6 @@ subroutine psb_c_csr_reallocate_nz(nz,a) integer(psb_ipk_), intent(in) :: nz class(psb_c_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_csr_reallocate_nz' logical, parameter :: debug=.false. @@ -1736,7 +1732,6 @@ subroutine psb_c_csr_mold(a,b,info) class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csr_mold' logical, parameter :: debug=.false. @@ -1846,7 +1841,6 @@ subroutine psb_c_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2021,7 +2015,6 @@ subroutine psb_c_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_, chksz_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2206,8 +2199,6 @@ subroutine psb_c_csr_tril(a,l,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_), allocatable :: ia(:), ja(:) - complex(psb_spk_), allocatable :: val(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ @@ -2362,8 +2353,6 @@ subroutine psb_c_csr_triu(a,u,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_), allocatable :: ia(:), ja(:) - complex(psb_spk_), allocatable :: val(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ @@ -2515,7 +2504,6 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_csr_csput_a' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit @@ -2527,28 +2515,24 @@ subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) debug_level = psb_get_debug_level() if (nz <= 0) then - info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_iarg_neg_; i=1 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=2 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=3 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=4 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if @@ -2652,7 +2636,7 @@ contains i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2680,7 +2664,7 @@ contains i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2720,7 +2704,7 @@ contains i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2742,7 +2726,7 @@ contains i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2776,7 +2760,6 @@ subroutine psb_c_csr_reinit(a,clear) logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -2821,7 +2804,6 @@ subroutine psb_c_csr_trim(a) implicit none class(psb_c_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz, m - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -2856,7 +2838,6 @@ subroutine psb_c_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='c_csr_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='complex' @@ -3446,3 +3427,2179 @@ contains end subroutine csr_spspmm end subroutine psb_ccsrspspmm + + +! +! +! lc version +! +! +subroutine psb_lc_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_get_diag + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = cone + else + do i=1, mnm + d(i) = czero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = czero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lc_csr_get_diag + + +subroutine psb_lc_csr_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_scal + use psb_string_mod + implicit none + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lc_csr_scal + + +subroutine psb_lc_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_scals + implicit none + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lc_csr_scals + + +function psb_lc_csr_maxval(a) result(res) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_maxval + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: nnz + integer(psb_ipk_) :: info + character(len=20) :: name='lc_csr_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_lc_csr_maxval + +function psb_lc_csr_csnmi(a) result(res) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csnmi + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nr, ir, jc, nc + real(psb_spk_) :: acc + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_csnmi' + logical, parameter :: debug=.false. + + + res = szero + if (a%is_dev()) call a%sync() + + do i = 1, a%get_nrows() + acc = szero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_lc_csr_csnmi + +subroutine psb_lc_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_rowsum + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = czero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + cone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_rowsum + +subroutine psb_lc_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_arwsum + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = szero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + sone + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_arwsum + +subroutine psb_lc_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_colsum + class(psb_lc_csr_sparse_mat), intent(in) :: a + complex(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_spk_) :: acc + complex(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = czero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + cone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_colsum + +subroutine psb_lc_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_aclsum + class(psb_lc_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = szero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + sone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_aclsum + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_lc_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_reallocate_nz + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='lc_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_reallocate_nz + +subroutine psb_lc_csr_mold(a,b,info) + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_mold + use psb_error_mod + implicit none + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csr_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lc_csr_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lc_csr_mold + +subroutine psb_lc_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_allocate_mnnz + + +subroutine psb_lc_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csgetptn + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_lc_csr_csgetrow + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_lc_csr_tril + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end if + end do + end do + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + l%val(nzin) = val(k) + end if + end if + end do + end do + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_tril + +subroutine psb_lc_csr_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_triu + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lc_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) + end if + end if + end do + end do + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_triu + + +subroutine psb_lc_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_csput_a + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_csr_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + + call psb_erractionsave(err_act) + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (nz <= 0) then + info = psb_err_iarg_neg_; + call psb_errpush(info,name,m_err=(/1/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/2/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/3/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/4/)) + goto 9999 + end if + + if (nz == 0) return + if (a%is_dev()) call a%sync() + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_lc_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_lc_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,ng + integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc + character(len=20) :: name='lc_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_lc_csr_srch_upd + +end subroutine psb_lc_csr_csput_a + + +subroutine psb_lc_csr_reinit(a,clear) + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_reinit + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = czero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_reinit + +subroutine psb_lc_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_trim + implicit none + class(psb_lc_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csr_trim + +subroutine psb_lc_csr_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_csr_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lc_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lc_csr_print' + logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_lc_csr_print + + +subroutine psb_lc_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_from_coo + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_lc_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k,ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='lc_cp_csr_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_lc_base_sparse_mat = tmp%psb_lc_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + + +end subroutine psb_lc_cp_csr_from_coo + + + +subroutine psb_lc_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_to_coo + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_lc_cp_csr_to_coo + + +subroutine psb_lc_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_to_coo + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,k,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_lc_mv_csr_to_coo + + + +subroutine psb_lc_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_from_coo + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k, ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='mv_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + +end subroutine psb_lc_mv_csr_from_coo + + +subroutine psb_lc_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_to_fmt + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_lc_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lc_mv_csr_to_fmt + + +subroutine psb_lc_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_to_fmt + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_lc_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lc_base_sparse_mat = a%psb_lc_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lc_cp_csr_to_fmt + + +subroutine psb_lc_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_mv_csr_from_fmt + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_lc_csr_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_lc_mv_csr_from_fmt + + + +subroutine psb_lc_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_c_base_mat_mod + use psb_realloc_mod + use psb_c_csr_mat_mod, psb_protect_name => psb_lc_cp_csr_from_fmt + implicit none + + class(psb_lc_csr_sparse_mat), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lc_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lc_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_lc_csr_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_lc_base_sparse_mat = b%psb_lc_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_lc_cp_csr_from_fmt + +subroutine psb_lccsrspspmm(a,b,c,info) + use psb_c_mat_mod + use psb_serial_mod, psb_protect_name => psb_lccsrspspmm + + implicit none + + class(psb_lc_csr_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_lc_csr_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: irow(:), idxs(:) + complex(psb_spk_), allocatable :: row(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + complex(psb_spk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + + + end subroutine csr_spspmm + +end subroutine psb_lccsrspspmm + diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index c48e796f6..08532e12e 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -37,8 +37,6 @@ ! for actually executing the method. ! ! -! - ! == =================================== @@ -2434,5 +2432,2423 @@ subroutine psb_c_scals(d,a,info) end subroutine psb_c_scals +subroutine psb_c_mv_from_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_mv_from_lb + implicit none + + class(psb_cspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%mv_from_lfmt(b,info) + +end subroutine psb_c_mv_from_lb + + +subroutine psb_c_cp_from_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cp_from_lb + implicit none + + class(psb_cspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%cp_from_lfmt(b,info) + +end subroutine psb_c_cp_from_lb + +subroutine psb_c_mv_to_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_mv_to_lb + implicit none + + class(psb_cspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%mv_to_lfmt(b,info) + call a%free() + end if + +end subroutine psb_c_mv_to_lb + +subroutine psb_c_cp_to_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cp_to_lb + implicit none + class(psb_cspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%cp_to_lfmt(b,info) + end if + +end subroutine psb_c_cp_to_lb + +subroutine psb_c_mv_from_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_mv_from_l + implicit none + class(psb_cspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info) + call a%a%mv_from_lfmt(b%a,info) + else + call a%free() + end if + call b%free() + +end subroutine psb_c_mv_from_l + + +subroutine psb_c_cp_from_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cp_from_l + implicit none + + class(psb_cspmat_type), intent(out) :: a + class(psb_lcspmat_type), intent(in) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_c_csr_sparse_mat :: a%a, stat=info) + call a%a%cp_from_lfmt(b%a,info) + else + call a%free() + end if +end subroutine psb_c_cp_from_l + +subroutine psb_c_mv_to_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_mv_to_l + implicit none + + class(psb_cspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_lc_csr_sparse_mat :: b%a, stat=info) + call a%a%mv_to_lfmt(b%a,info) + else + call b%free() + end if + call a%free() + +end subroutine psb_c_mv_to_l + +subroutine psb_c_cp_to_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_c_cp_to_l + implicit none + + class(psb_cspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_lc_csr_sparse_mat :: b%a, stat=info) + call a%a%cp_to_lfmt(b%a,info) + else + call b%free() + end if + +end subroutine psb_c_cp_to_l +! +! +! lc versions +! + + +subroutine psb_lc_set_nrows(m,a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_nrows + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_nrows + + +subroutine psb_lc_set_ncols(n,a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_ncols + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_ncols + + + +! +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ +! + +subroutine psb_lc_set_dupl(n,a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_dupl + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_dupl + + +! +! Set the STATE of the internal matrix object +! + +subroutine psb_lc_set_null(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_null + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_null + + +subroutine psb_lc_set_bld(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_bld + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_bld + + +subroutine psb_lc_set_upd(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_upd + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lc_set_upd + + +subroutine psb_lc_set_asb(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_asb + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_asb + + +subroutine psb_lc_set_sorted(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_sorted + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_sorted + + +subroutine psb_lc_set_triangle(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_triangle + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_triangle + + +subroutine psb_lc_set_unit(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_unit + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_unit + + +subroutine psb_lc_set_lower(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_lower + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_lower + + +subroutine psb_lc_set_upper(a,val) + use psb_c_mat_mod, psb_protect_name => psb_lc_set_upper + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_lc_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_c_mat_mod, psb_protect_name => psb_lc_sparse_print + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,head,ivr,ivc) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_sparse_print + + +subroutine psb_lc_n_sparse_print(fname,a,iv,head,ivr,ivc) + use psb_c_mat_mod, psb_protect_name => psb_lc_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info, iout + logical :: isopen + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call a%a%print(iout,iv,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_n_sparse_print + + +subroutine psb_lc_get_neigh(a,idx,neigh,n,info,lev) + use psb_c_mat_mod, psb_protect_name => psb_lc_get_neigh + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_get_neigh + + + +subroutine psb_lc_csall(nr,nc,a,info,nz) + use psb_c_mat_mod, psb_protect_name => psb_lc_csall + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + call a%free() + + info = psb_success_ + allocate(psb_lc_coo_sparse_mat :: a%a, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csall + + +subroutine psb_lc_reallocate_nz(nz,a) + use psb_c_mat_mod, psb_protect_name => psb_lc_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_reallocate_nz + + +subroutine psb_lc_free(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_free + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_lc_free + + +subroutine psb_lc_trim(a) + use psb_c_mat_mod, psb_protect_name => psb_lc_trim + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_trim + + + +subroutine psb_lc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_mat_mod, psb_protect_name => psb_lc_csput_a + use psb_c_base_mat_mod + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_a' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csput_a + +subroutine psb_lc_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_c_mat_mod, psb_protect_name => psb_lc_csput_v + use psb_c_base_mat_mod + use psb_c_vect_mod, only : psb_c_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + use psb_error_mod + implicit none + class(psb_lcspmat_type), intent(inout) :: a + type(psb_c_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csput_v + + +subroutine psb_lc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_csgetptn + implicit none + + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csgetptn + + +subroutine psb_lc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_csgetrow + implicit none + + class(psb_lcspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csgetrow + + + + +subroutine psb_lc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_csgetblk + implicit none + + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + logical :: append_ + type(psb_lc_coo_sparse_mat), allocatable :: acoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(append)) then + append_ = append + else + append_ = .false. + end if + + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then + if (allocated(b%a)) & + & call b%a%mv_to_coo(acoo,info) + end if + + if (info == psb_success_) then + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csgetblk + + +subroutine psb_lc_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_tril + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lcspmat_type), optional, intent(inout) :: u + + integer(psb_ipk_) :: err_act + character(len=20) :: name='tril' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat), allocatable :: lcoo, ucoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(lcoo,stat=info) + call l%free() + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lc_tril + +subroutine psb_lc_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_triu + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lcspmat_type), optional, intent(inout) :: l + + integer(psb_ipk_) :: err_act + character(len=20) :: name='triu' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat), allocatable :: lcoo, ucoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ucoo,stat=info) + call u%free() + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lc_triu + + +subroutine psb_lc_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_csclip + implicit none + + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_lc_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + call b%free() + if (info == psb_success_) then + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_csclip + + +subroutine psb_lc_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_c_base_mat_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_b_csclip + implicit none + + class(psb_lcspmat_type), intent(in) :: a + type(psb_lc_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_b_csclip + + + + +subroutine psb_lc_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cscnv + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_lc_base_sparse_mat), intent(in), optional :: mold + + + class(psb_lc_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_lc_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_lc_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_lc_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(dupl)) then + call altmp%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call altmp%set_dupl(psb_dupl_def_) + end if + + if (debug) write(psb_err_unit,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%trim() + call b%asb() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cscnv + + + +subroutine psb_lc_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cscnv_ip + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_lc_base_sparse_mat), intent(in), optional :: mold + + + class(psb_lc_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_lc_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_lc_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_lc_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cscnv_ip + + + +subroutine psb_lc_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cscnv_base + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + + + type(psb_lc_coo_sparse_mat) :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == psb_success_).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_cscnv_base + + + +!!$subroutine psb_lc_clip_d(a,b,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_c_base_mat_mod +!!$ use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d +!!$ implicit none +!!$ +!!$ class(psb_lcspmat_type), intent(in) :: a +!!$ class(psb_lcspmat_type), intent(inout) :: b +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_lc_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call b%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_lc_clip_d +!!$ +!!$ +!!$ +!!$subroutine psb_lc_clip_d_ip(a,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_c_base_mat_mod +!!$ use psb_c_mat_mod, psb_protect_name => psb_lc_clip_d_ip +!!$ implicit none +!!$ +!!$ class(psb_lcspmat_type), intent(inout) :: a +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_lc_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call a%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_lc_clip_d_ip +!!$ + +subroutine psb_lc_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_mv_from + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call a%free() + allocate(a%a,mold=b, stat=info) + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_lc_mv_from + + +subroutine psb_lc_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cp_from + implicit none + class(psb_lcspmat_type), intent(out) :: a + class(psb_lc_base_sparse_mat), intent(in) :: b + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + call a%free() + ! + ! Note: it is tempting to use SOURCE allocation below; + ! however this would run the risk of messing up with data + ! allocated externally (e.g. GPU-side data). + ! + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lc_cp_from + + +subroutine psb_lc_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_mv_to + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_lc_mv_to + + +subroutine psb_lc_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cp_to + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lc_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_lc_cp_to + +subroutine psb_lc_mold(a,b) + use psb_c_mat_mod, psb_protect_name => psb_lc_mold + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), allocatable, intent(out) :: b + integer(psb_ipk_) :: info + + allocate(b,mold=a%a, stat=info) + +end subroutine psb_lc_mold + +subroutine psb_lcspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lcspmat_type_move + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call b%free() + call move_alloc(a%a,b%a) + + return +end subroutine psb_lcspmat_type_move + + +subroutine psb_lcspmat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lcspmat_clone + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lcspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lcspmat_clone + + +subroutine psb_lc_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_transp_1mat + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_transp_1mat + + + +subroutine psb_lc_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_transp_2mat + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_transp_2mat + + +subroutine psb_lc_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_transc_1mat + implicit none + class(psb_lcspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_transc_1mat + + + +subroutine psb_lc_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_transc_2mat + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_lcspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_transc_2mat + + +subroutine psb_lc_asb(a,mold) + use psb_c_mat_mod, psb_protect_name => psb_lc_asb + use psb_error_mod + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + class(psb_lc_base_sparse_mat), optional, intent(in) :: mold + class(psb_lc_base_sparse_mat), allocatable :: tmp + class(psb_lc_base_sparse_mat), pointer :: mld + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='lc_asb' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_lc_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_asb + +subroutine psb_lc_reinit(a,clear) + use psb_c_mat_mod, psb_protect_name => psb_lc_reinit + use psb_error_mod + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (a%a%has_update()) then + call a%a%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_reinit + + + + +function psb_lc_get_diag(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_get_diag + + +subroutine psb_lc_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_scal + implicit none + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info,side=side) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_scal + + +subroutine psb_lc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_scals + implicit none + class(psb_lcspmat_type), intent(inout) :: a + complex(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lc_scals + +function psb_lc_maxval(a) result(res) + use psb_c_mat_mod, psb_protect_name => psb_lc_maxval + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%maxval() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_maxval + +function psb_lc_csnmi(a) result(res) + use psb_c_mat_mod, psb_protect_name => psb_lc_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnmi() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_csnmi + +function psb_lc_csnm1(a) result(res) + use psb_c_mat_mod, psb_protect_name => psb_lc_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnm1() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_csnm1 + + +function psb_lc_rowsum(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + call a%a%rowsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_rowsum + +function psb_lc_arwsum(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%arwsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_arwsum + +function psb_lc_colsum(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + complex(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%colsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_colsum + +function psb_lc_aclsum(a,info) result(d) + use psb_c_mat_mod, psb_protect_name => psb_lc_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lcspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%aclsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lc_aclsum + +subroutine psb_lc_mv_from_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_mv_from_ib + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + if (.not.allocated(a%a)) allocate(psb_lc_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%mv_from_ifmt(b,info) + +end subroutine psb_lc_mv_from_ib + +subroutine psb_lc_cp_from_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cp_from_ib + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) allocate(psb_lc_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%cp_from_ifmt(b,info) + +end subroutine psb_lc_cp_from_ib + +subroutine psb_lc_mv_to_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_mv_to_ib + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%mv_to_ifmt(b,info) + call a%free() + end if + +end subroutine psb_lc_mv_to_ib + +subroutine psb_lc_cp_to_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cp_to_ib + implicit none + class(psb_lcspmat_type), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%cp_to_ifmt(b,info) + end if + +end subroutine psb_lc_cp_to_ib + +subroutine psb_lc_mv_from_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_mv_from_i + implicit none + class(psb_lcspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_lc_csr_sparse_mat :: a%a, stat=info) + call a%a%mv_from_ifmt(b%a,info) + else + call a%free() + end if + call b%free() + +end subroutine psb_lc_mv_from_i + + +subroutine psb_lc_cp_from_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cp_from_i + implicit none + + class(psb_lcspmat_type), intent(out) :: a + class(psb_cspmat_type), intent(in) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_lc_csr_sparse_mat :: a%a, stat=info) + call a%a%cp_from_ifmt(b%a,info) + else + call a%free() + end if +end subroutine psb_lc_cp_from_i + +subroutine psb_lc_mv_to_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_mv_to_i + implicit none + + class(psb_lcspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_c_csr_sparse_mat :: b%a, stat=info) + call a%a%mv_to_ifmt(b%a,info) + else + call b%free() + end if + call a%free() + +end subroutine psb_lc_mv_to_i + +subroutine psb_lc_cp_to_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_c_mat_mod, psb_protect_name => psb_lc_cp_to_i + implicit none + + class(psb_lcspmat_type), intent(in) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_c_csr_sparse_mat :: b%a, stat=info) + call a%a%cp_to_ifmt(b%a,info) + else + call b%free() + end if + +end subroutine psb_lc_cp_to_i + + + + diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index 59c9975d7..332c1a7b9 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -50,8 +50,7 @@ subroutine psb_d_base_cp_to_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -75,8 +74,7 @@ subroutine psb_d_base_cp_from_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -101,8 +99,7 @@ subroutine psb_d_base_cp_to_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp @@ -144,8 +141,7 @@ subroutine psb_d_base_cp_from_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp @@ -190,8 +186,7 @@ subroutine psb_d_base_mv_to_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -228,8 +223,7 @@ subroutine psb_d_base_mv_from_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -266,8 +260,7 @@ subroutine psb_d_base_mv_to_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp @@ -297,8 +290,7 @@ subroutine psb_d_base_mv_from_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_d_coo_sparse_mat) :: tmp @@ -344,8 +336,7 @@ subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csput' logical, parameter :: debug=.false. @@ -372,8 +363,7 @@ subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csput_v' integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ @@ -423,8 +413,7 @@ subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -439,8 +428,6 @@ subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end subroutine psb_d_base_csgetrow - - ! ! Here we have the base implementation of getblk and clip: ! this is just based on the getrow. @@ -462,10 +449,9 @@ subroutine psb_d_base_csgetblk(imin,imax,a,b,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csget' - integer(psb_ipk_) :: jmin_, jmax_ + integer(psb_ipk_) :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. @@ -554,8 +540,7 @@ subroutine psb_d_base_csclip(a,b,info,& integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb character(len=20) :: name='csget' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -649,7 +634,6 @@ subroutine psb_d_base_tril(a,l,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_dpk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -801,7 +785,6 @@ subroutine psb_d_base_triu(a,u,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_dpk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -1000,8 +983,7 @@ subroutine psb_d_base_mold(a,b,info) class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='base_mold' logical, parameter :: debug=.false. @@ -1026,7 +1008,6 @@ subroutine psb_d_base_transp_2mat(a,b) type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='d_base_transp' call psb_erractionsave(err_act) @@ -1041,8 +1022,7 @@ subroutine psb_d_base_transp_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1)=ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1064,7 +1044,6 @@ subroutine psb_d_base_transc_2mat(a,b) type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='d_base_transc' call psb_erractionsave(err_act) @@ -1079,8 +1058,7 @@ subroutine psb_d_base_transc_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1) = ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1101,7 +1079,6 @@ subroutine psb_d_base_transp_1mat(a) type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='d_base_transp' call psb_erractionsave(err_act) @@ -1133,7 +1110,6 @@ subroutine psb_d_base_transc_1mat(a) type(psb_d_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='d_base_transc' call psb_erractionsave(err_act) @@ -1182,8 +1158,7 @@ subroutine psb_d_base_csmm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_csmm' logical, parameter :: debug=.false. @@ -1209,8 +1184,7 @@ subroutine psb_d_base_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_csmv' logical, parameter :: debug=.false. @@ -1237,8 +1211,7 @@ subroutine psb_d_base_inner_cssm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_inner_cssm' logical, parameter :: debug=.false. @@ -1264,8 +1237,7 @@ subroutine psb_d_base_inner_cssv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_inner_cssv' logical, parameter :: debug=.false. @@ -1296,7 +1268,6 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) real(psb_dpk_), allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act, nar,nac,nc, i character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_cssm' logical, parameter :: debug=.false. @@ -1313,14 +1284,12 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) nc = min(size(x,2), size(y,2)) if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1340,8 +1309,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1364,8 +1332,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1389,8 +1356,7 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1404,16 +1370,13 @@ subroutine psb_d_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - end subroutine psb_d_base_cssm @@ -1430,9 +1393,8 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) real(psb_dpk_), intent(in), optional :: d(:) real(psb_dpk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='d_cssm' logical, parameter :: debug=.false. @@ -1449,14 +1411,12 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1476,8 +1436,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1495,8 +1454,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1520,8 +1478,7 @@ subroutine psb_d_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1580,8 +1537,7 @@ subroutine psb_d_base_scals(d,a,info) real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_scals' logical, parameter :: debug=.false. @@ -1607,8 +1563,7 @@ subroutine psb_d_base_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_scal' logical, parameter :: debug=.false. @@ -1623,8 +1578,6 @@ subroutine psb_d_base_scal(d,a,info,side) end subroutine psb_d_base_scal - - function psb_d_base_maxval(a) result(res) use psb_error_mod use psb_const_mod @@ -1634,8 +1587,7 @@ function psb_d_base_maxval(a) result(res) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='maxval' logical, parameter :: debug=.false. @@ -1662,8 +1614,7 @@ function psb_d_base_csnmi(a) result(res) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' real(psb_dpk_), allocatable :: vt(:) @@ -1701,8 +1652,7 @@ function psb_d_base_csnm1(a) result(res) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' real(psb_dpk_), allocatable :: vt(:) @@ -1737,8 +1687,7 @@ subroutine psb_d_base_rowsum(d,a) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1760,8 +1709,7 @@ subroutine psb_d_base_arwsum(d,a) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='arwsum' logical, parameter :: debug=.false. @@ -1783,8 +1731,7 @@ subroutine psb_d_base_colsum(d,a) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1806,8 +1753,7 @@ subroutine psb_d_base_aclsum(d,a) class(psb_d_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1822,7 +1768,6 @@ subroutine psb_d_base_aclsum(d,a) end subroutine psb_d_base_aclsum - subroutine psb_d_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod @@ -1833,8 +1778,7 @@ subroutine psb_d_base_get_diag(a,d,info) real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -1900,9 +1844,8 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) real(psb_dpk_), allocatable :: tmp(:) class(psb_d_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='d_cssm' logical, parameter :: debug=.false. @@ -1919,14 +1862,12 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (x%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (y%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1949,8 +1890,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) @@ -1968,8 +1908,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1995,8 +1934,7 @@ subroutine psb_d_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -2034,8 +1972,7 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_inner_vect_sv' logical, parameter :: debug=.false. @@ -2059,3 +1996,2039 @@ subroutine psb_d_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) return end subroutine psb_d_base_inner_vect_sv + + +subroutine psb_d_base_cp_to_lcoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_cp_to_lcoo + +subroutine psb_d_base_cp_from_lcoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_lcoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_cp_from_lcoo + +subroutine psb_d_base_cp_to_lfmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: icoo + type(psb_ld_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%cp_to_lcoo(b,info) + class default + call a%cp_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call b%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_cp_to_lfmt + +subroutine psb_d_base_cp_from_lfmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_cp_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: icoo + type(psb_ld_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%cp_from_lcoo(b,info) + class default + call b%cp_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call a%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_cp_from_lfmt + + +subroutine psb_d_base_mv_to_lcoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_mv_to_lcoo + +subroutine psb_d_base_mv_from_lcoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lcoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_mv_from_lcoo + + +subroutine psb_d_base_mv_to_lfmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: icoo + type(psb_ld_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%mv_to_lcoo(b,info) + class default + call a%mv_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call b%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_mv_to_lfmt + +subroutine psb_d_base_mv_from_lfmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mv_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: icoo + type(psb_ld_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%mv_from_lcoo(b,info) + class default + call b%mv_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call a%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_base_mv_from_lfmt + +! +! +! ld implementation +! +! +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_ld_base_cp_to_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_cp_to_coo + +subroutine psb_ld_base_cp_from_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_cp_from_coo + + +subroutine psb_ld_base_cp_to_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_to_fmt + +subroutine psb_ld_base_cp_from_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_from_fmt + + +subroutine psb_ld_base_mv_to_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_to_coo + +subroutine psb_ld_base_mv_from_coo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_from_coo + + +subroutine psb_ld_base_mv_to_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_ld_base_mv_to_fmt + +subroutine psb_ld_base_mv_from_fmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ld_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_ld_base_mv_from_fmt + +subroutine psb_ld_base_clean_zeros(a, info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_clean_zeros + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + ! + type(psb_ld_coo_sparse_mat) :: tmpcoo + + call a%mv_to_coo(tmpcoo,info) + if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call a%mv_from_coo(tmpcoo,info) + +end subroutine psb_ld_base_clean_zeros + + +subroutine psb_ld_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_a + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_csput_a + +subroutine psb_ld_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csput_v + use psb_d_base_vect_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + if (a%is_dev()) call a%sync() + if (val%is_dev()) call val%sync() + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_csput_v + +subroutine psb_ld_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csgetrow + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_csgetrow + + + +! +! Here we have the base implementation of getblk and clip: +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_ld_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csgetblk + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout + character(len=20) :: name='csget' + integer(psb_lpk_) :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + if (present(rscale)) then + rscale_=rscale + else + rscale_=.false. + end if + if (present(cscale)) then + cscale_=cscale + else + cscale_=.false. + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if (append_.and.(rscale_.or.cscale_)) then + write(psb_err_unit,*) & + & 'ld_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' + end if + + if (rscale_) then + call b%set_nrows(imax-imin+1) + else + call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) + end if + + if (cscale_) then + call b%set_ncols(jmax_-jmin_+1) + else + call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) + end if + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_csgetblk + + +subroutine psb_ld_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csclip + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_csclip + + +! +! Here we have the base implementation of tril and triu +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_ld_base_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_tril + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + real(psb_dpk_), allocatable :: val(:) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + integer(psb_lpk_), parameter :: nbk=8 + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_, nbk + ibk = min(nbk,imax_-i+1) + call a%csget(i,i+ibk-1,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + if ((ja(k)-ia(k))<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = ia(k) + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = ia(k) + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end do + end do + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + do i=imin_,imax_ + k = min(jmax_,i+diag_) + call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& + & jmin=jmin_, jmax=k, append=.true., & + & nzin=nzin) + if (info /= psb_success_) goto 9999 + call l%set_nzeros(nzin+nzout) + nzin = nzin+nzout + end do + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_tril + +subroutine psb_ld_base_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_triu + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + real(psb_dpk_), allocatable :: val(:) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + integer(psb_lpk_), parameter :: nbk=8 + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_, nbk + ibk = min(nbk,imax_-i+1) + call a%csget(i,i+ibk-1,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + if ((ja(k)-ia(k))= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_triu + + + +subroutine psb_ld_base_clone(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_clone + use psb_error_mod + implicit none + + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b, stat=info) + end if + if (info /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + + ! Do not use SOURCE allocation: this makes sure that + ! memory allocated elsewhere is treated properly. + allocate(b,mold=a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%cp_from_fmt(a, info) + +end subroutine psb_ld_base_clone + +subroutine psb_ld_base_make_nonunit(a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_make_nonunit + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + type(psb_ld_coo_sparse_mat) :: tmp + + integer(psb_ipk_) :: info + integer(psb_lpk_) :: i, j, m, n, nz, mnm + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) + if (info /= 0) return + m = tmp%get_nrows() + n = tmp%get_ncols() + mnm = min(m,n) + nz = tmp%get_nzeros() + call tmp%reallocate(nz+mnm) + do i=1, mnm + tmp%val(nz+i) = done + tmp%ia(nz+i) = i + tmp%ja(nz+i) = i + end do + call tmp%set_nzeros(nz+mnm) + call tmp%set_unit(.false.) + call tmp%fix(info) + if (info /= 0) & + & call a%mv_from_coo(tmp,info) + end if + +end subroutine psb_ld_base_make_nonunit + +subroutine psb_ld_base_mold(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mold + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_mold' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_mold + +subroutine psb_ld_base_transp_2mat(a,b) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ld_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_ld_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_transp_2mat + +subroutine psb_ld_base_transc_2mat(a,b) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transc_2mat + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ld_base_transc' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_ld_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ld_base_transc_2mat + +subroutine psb_ld_base_transp_1mat(a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_ld_base_sparse_mat), intent(inout) :: a + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ld_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_transp_1mat + +subroutine psb_ld_base_transc_1mat(a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_transc_1mat + implicit none + + class(psb_ld_base_sparse_mat), intent(inout) :: a + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ld_base_transc' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_transc_1mat + +subroutine psb_ld_base_scals(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scals + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_scals' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_scals + +subroutine psb_ld_base_scal(d,a,info,side) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_scal + use psb_error_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_scal + +function psb_ld_base_maxval(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_maxval + + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + res = dzero + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end function psb_ld_base_maxval + +function psb_ld_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csnmi + + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + real(psb_dpk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = dzero + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%arwsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_base_csnmi + +function psb_ld_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_csnm1 + + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + real(psb_dpk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = dzero + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%aclsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_base_csnm1 + +subroutine psb_ld_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_rowsum + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_rowsum + +subroutine psb_ld_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_arwsum + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_arwsum + +subroutine psb_ld_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_colsum + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_colsum + +subroutine psb_ld_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_aclsum + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_aclsum + +subroutine psb_ld_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_get_diag + + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ld_base_get_diag + + + +subroutine psb_ld_base_cp_to_icoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_to_icoo + +subroutine psb_ld_base_cp_from_icoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_from_icoo + + +subroutine psb_ld_base_cp_to_ifmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: icoo + type(psb_ld_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_d_coo_sparse_mat) + call a%cp_to_icoo(b,info) + class default + call a%cp_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call b%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_to_ifmt + +subroutine psb_ld_base_cp_from_ifmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_cp_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: icoo + type(psb_ld_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_d_coo_sparse_mat) + call a%cp_from_icoo(b,info) + class default + call b%cp_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call a%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_cp_from_ifmt + + +subroutine psb_ld_base_mv_to_icoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_icoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_to_icoo + +subroutine psb_ld_base_mv_from_icoo(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_from_icoo + + +subroutine psb_ld_base_mv_to_ifmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: icoo + type(psb_ld_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_d_coo_sparse_mat) + call a%mv_to_icoo(b,info) + class default + call a%mv_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call b%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_to_ifmt + +subroutine psb_ld_base_mv_from_ifmt(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_base_mv_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ld_base_sparse_mat), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_d_coo_sparse_mat) :: icoo + type(psb_ld_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_d_coo_sparse_mat) + call a%mv_from_icoo(b,info) + class default + call b%mv_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call a%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_base_mv_from_ifmt + + diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index 47c0b1072..27f22219b 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -29,7 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - subroutine psb_d_coo_get_diag(a,d,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_get_diag use psb_error_mod @@ -39,8 +38,7 @@ subroutine psb_d_coo_get_diag(a,d,info) real(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -51,8 +49,7 @@ subroutine psb_d_coo_get_diag(a,d,info) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -88,8 +85,7 @@ subroutine psb_d_coo_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ logical :: left @@ -114,8 +110,7 @@ subroutine psb_d_coo_scal(d,a,info,side) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -127,8 +122,7 @@ subroutine psb_d_coo_scal(d,a,info,side) m = a%get_ncols() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -158,8 +152,7 @@ subroutine psb_d_coo_scals(d,a,info) real(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -193,15 +186,16 @@ subroutine psb_d_coo_reallocate_nz(nz,a) implicit none integer(psb_ipk_), intent(in) :: nz class(psb_d_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='d_coo_reallocate_nz' logical, parameter :: debug=.false. call psb_erractionsave(err_act) nz_ = max(nz,ione) - call psb_realloc(nz_,a%ia,a%ja,a%val,info) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -224,8 +218,7 @@ subroutine psb_d_coo_mold(a,b,info) class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. @@ -259,8 +252,7 @@ subroutine psb_d_coo_reinit(a,clear) class(psb_d_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -306,8 +298,7 @@ subroutine psb_d_coo_trim(a) use psb_error_mod implicit none class(psb_d_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -363,8 +354,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) integer(psb_ipk_), intent(in) :: m,n class(psb_d_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='allocate_mnz' logical, parameter :: debug=.false. @@ -372,14 +362,12 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) info = psb_success_ if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif if (present(nz)) then @@ -389,8 +377,7 @@ subroutine psb_d_coo_allocate_mnnz(m,n,a,nz) end if if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 endif if (info == psb_success_) call psb_realloc(nz_,a%ia,info) @@ -431,13 +418,12 @@ subroutine psb_d_coo_print(iout,a,iv,head,ivr,ivc) character(len=*), optional :: head integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='real' - character(len=80) :: frmtv + character(len=80) :: frmtv integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' @@ -507,7 +493,7 @@ function psb_d_coo_get_nz_row(idx,a) result(res) nza = a%get_nzeros() if (a%is_by_rows()) then ! In this case we can do a binary search. - ip = psb_ibsrch(idx,nza,a%ia) + ip = psb_bsrch(idx,nza,a%ia) if (ip /= -1) return jp = ip do @@ -560,8 +546,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) real(psb_dpk_) :: acc real(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_csmm' logical, parameter :: debug=.false. @@ -591,14 +576,12 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -916,8 +899,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) real(psb_dpk_) :: acc real(psb_dpk_), allocatable :: tmp(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_cssv_impl' logical, parameter :: debug=.false. @@ -941,14 +923,12 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if if (.not. (a%is_triangle())) then @@ -1260,8 +1240,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc real(psb_dpk_) :: acc logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_csmv_impl' logical, parameter :: debug=.false. @@ -1295,16 +1274,15 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if + nnz = a%get_nzeros() if (alpha == dzero) then @@ -1448,15 +1426,14 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans character :: trans_ integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc real(psb_dpk_), allocatable :: acc(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_csmm_impl' logical, parameter :: debug=.false. @@ -1492,14 +1469,12 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -1652,8 +1627,7 @@ function psb_d_coo_maxval(a) result(res) class(psb_d_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info character(len=20) :: name='d_coo_maxval' logical, parameter :: debug=.false. @@ -1684,7 +1658,6 @@ function psb_d_coo_csnmi(a) result(res) real(psb_dpk_), allocatable :: vt(:) logical :: tra, is_unit integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_coo_csnmi' logical, parameter :: debug=.false. @@ -1746,7 +1719,6 @@ function psb_d_coo_csnm1(a) result(res) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_coo_csnm1' logical, parameter :: debug=.false. @@ -1785,7 +1757,6 @@ subroutine psb_d_coo_rowsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1793,10 +1764,10 @@ subroutine psb_d_coo_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() + if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1834,7 +1805,6 @@ subroutine psb_d_coo_arwsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1844,8 +1814,7 @@ subroutine psb_d_coo_arwsum(d,a) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1882,7 +1851,6 @@ subroutine psb_d_coo_colsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1892,8 +1860,7 @@ subroutine psb_d_coo_colsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if @@ -1931,7 +1898,6 @@ subroutine psb_d_coo_aclsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1941,11 +1907,11 @@ subroutine psb_d_coo_aclsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if + if (a%is_unit()) then d = done else @@ -1969,7 +1935,6 @@ subroutine psb_d_coo_aclsum(d,a) end subroutine psb_d_coo_aclsum - ! == ================================== ! ! @@ -2004,8 +1969,7 @@ subroutine psb_d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, intent(in), optional :: rscale,cscale logical :: append_, rscale_, cscale_ - integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2121,7 +2085,7 @@ contains if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do - ip = psb_ibsrch(irw,nza,a%ia) + ip = psb_bsrch(irw,nza,a%ia) if (ip /= -1) exit irw = irw + 1 if (irw > imax) then @@ -2146,7 +2110,7 @@ contains end if do - jp = psb_ibsrch(lrw,nza,a%ia) + jp = psb_bsrch(lrw,nza,a%ia) if (jp /= -1) exit lrw = lrw - 1 if (irw > lrw) then @@ -2280,7 +2244,6 @@ subroutine psb_d_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_, chksz_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2404,7 +2367,7 @@ contains if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do - ip = psb_ibsrch(irw,nza,a%ia) + ip = psb_bsrch(irw,nza,a%ia) if (ip /= -1) exit irw = irw + 1 if (irw > imax) then @@ -2429,7 +2392,7 @@ contains end if do - jp = psb_ibsrch(lrw,nza,a%ia) + jp = psb_bsrch(lrw,nza,a%ia) if (jp /= -1) exit lrw = lrw - 1 if (irw > lrw) then @@ -2566,12 +2529,11 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='d_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2580,27 +2542,23 @@ subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (nz < 0) then info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 end if @@ -2760,7 +2718,7 @@ contains if ((ir > 0).and.(ir <= nr)) then ic = gtl(ic) if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2778,7 +2736,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2802,7 +2760,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2820,7 +2778,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2853,7 +2811,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2871,7 +2829,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2890,7 +2848,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2908,7 +2866,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2941,8 +2899,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -2984,8 +2941,7 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3031,8 +2987,7 @@ subroutine psb_d_cp_coo_to_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3064,8 +3019,7 @@ subroutine psb_d_cp_coo_from_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3099,8 +3053,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3142,8 +3095,7 @@ subroutine psb_d_mv_coo_from_coo(a,b,info) class(psb_d_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3187,8 +3139,7 @@ subroutine psb_d_mv_coo_to_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3220,8 +3171,7 @@ subroutine psb_d_mv_coo_from_fmt(a,b,info) class(psb_d_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3255,8 +3205,7 @@ subroutine psb_d_coo_cp_from(a,b) type(psb_d_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. @@ -3286,8 +3235,7 @@ subroutine psb_d_coo_mv_from(a,b) type(psb_d_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='mv_from' logical, parameter :: debug=.false. @@ -3324,7 +3272,6 @@ subroutine psb_d_fix_coo(a,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca integer(psb_ipk_) :: i,j, irw, icl, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' info = psb_success_ @@ -3375,6 +3322,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_d_base_mat_mod, psb_protect_name => psb_d_fix_coo_inner use psb_string_mod use psb_ip_reord_mod + use psb_sort_mod implicit none integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl @@ -3388,7 +3336,6 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_ integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers @@ -3461,7 +3408,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ja(i:imx),ix2,iret) + call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3572,7 +3519,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,jas(i:imx),ix2,iret) + call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3665,7 +3612,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! If we did not have enough memory for buffers, ! let's try in place. ! - call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret) + call psi_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3677,7 +3624,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret) + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3784,7 +3731,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ia(i:imx),ix2,iret) + call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3893,7 +3840,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ias(i:imx),ix2,iret) + call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3980,7 +3927,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret) + call psi_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3991,7 +3938,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret) + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -4082,3 +4029,3102 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_d_fix_coo_inner + +subroutine psb_d_cp_coo_to_lcoo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_to_lcoo + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lbase_sparse_mat = a%psb_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_d_cp_coo_to_lcoo + +subroutine psb_d_cp_coo_from_lcoo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_d_cp_coo_from_lcoo + implicit none + class(psb_d_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_base_sparse_mat = b%psb_lbase_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_d_cp_coo_from_lcoo + + +! +! +! ld coo impl +! +! + +subroutine psb_ld_coo_get_diag(a,d,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + if (a%is_unit()) then + d(1:mnm) = done + else + d(1:mnm) = dzero + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_get_diag + +subroutine psb_ld_coo_scal(d,a,info,side) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scal + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_scal + + +subroutine psb_ld_coo_scals(d,a,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_scals + + +function psb_ld_coo_maxval(a) result(res) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_maxval + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + character(len=20) :: name='d_coo_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + res = done + else + res = dzero + end if + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if + +end function psb_ld_coo_maxval + +function psb_ld_coo_csnmi(a) result(res) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnmi + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_coo_csnmi' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + is_unit = a%is_unit() + if (a%is_by_rows()) then + i = 1 + j = i + res = dzero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + if (is_unit) then + acc = done + else + acc = dzero + end if + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + if (is_unit) then + vt = done + else + vt = dzero + end if + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_ld_coo_csnmi + + +function psb_ld_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csnm1 + + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_coo_csnm1' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + if (a%is_unit()) then + vt = done + else + vt = dzero + end if + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_ld_coo_csnm1 + +subroutine psb_ld_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_rowsum + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_rowsum + +subroutine psb_ld_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_arwsum + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_arwsum + +subroutine psb_ld_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_colsum + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_colsum + +subroutine psb_ld_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_aclsum + class(psb_ld_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_aclsum + +subroutine psb_ld_coo_reallocate_nz(nz,a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='ld_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + nz_ = max(nz,ione) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_reallocate_nz + +subroutine psb_ld_coo_mold(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mold + use psb_error_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='coo_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ld_coo_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_mold + +subroutine psb_ld_coo_reinit(a,clear) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_reinit + use psb_error_mod + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_dev()) call a%sync() + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_host() + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_reinit + + + +subroutine psb_ld_coo_trim(a) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_trim + +subroutine psb_ld_coo_clean_zeros(a, info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_clean_zeros + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: info + ! + integer(psb_lpk_) :: i,j,k, nzin + + info = 0 + nzin = a%get_nzeros() + j = 0 + do i=1, nzin + if (a%val(i) /= dzero) then + j = j + 1 + a%val(j) = a%val(i) + a%ia(j) = a%ia(i) + a%ja(j) = a%ja(i) + end if + end do + call a%set_nzeros(j) + call a%trim() +end subroutine psb_ld_coo_clean_zeros + + + +subroutine psb_ld_coo_allocate_mnnz(m,n,a,nz) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,izero/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(lzero) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + ! An empty matrix is sorted! + call a%set_sorted(.true.) + call a%set_host() + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_allocate_mnnz + + + +subroutine psb_ld_coo_print(iout,a,iv,head,ivr,ivc) + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_print + use psb_string_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_coo_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_ld_coo_print + + + + +function psb_ld_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_get_nz_row + implicit none + + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k + integer(psb_ipk_) :: inza + + if (a%is_dev()) call a%sync() + res = 0 + nza = a%get_nzeros() + if (a%is_by_rows()) then + ! In this case we can do a binary search. + inza = nza + ip = psb_bsrch(idx,inza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_ld_coo_get_nz_row + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_ld_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csgetptn + implicit none + + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_ld_coo_csgetptn + + +! +! NZ is the number of non-zeros on output. +! The output is guaranteed to be sorted +! +subroutine psb_ld_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csgetrow + implicit none + + class(psb_ld_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = iren(a%ia(i)) + ja(nzin_+nz) = iren(a%ja(i)) + end if + enddo + call psb_ld_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = a%ia(i) + ja(nzin_+nz) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + end if + call psb_ld_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + end if + + end subroutine coo_getrow + +end subroutine psb_ld_coo_csgetrow + + +subroutine psb_ld_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_csput_a + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_coo_csput_a_impl' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (nz < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + endif + isza = a%get_size() + if (isza < (nza+nz)) then + info = psb_err_alloc_dealloc_; call psb_errpush(info,name) + goto 9999 + end if + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + if (a%is_dev()) call a%sync() + + call ld_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) + real(psb_dpk_), intent(in) :: val(:) + real(psb_dpk_), intent(inout) :: aspk(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine ld_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nnz,dupl,ng, nr + integer(psb_ipk_) :: debug_level, debug_unit, innz, nc + character(len=20) :: name='ld_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + innz = nnz + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + endif + else + info = max(info,1) + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine ld_coo_srch_upd + +end subroutine psb_ld_coo_csput_a + + +subroutine psb_ld_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_coo + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_to_coo + +subroutine psb_ld_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_coo + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_from_coo + + +subroutine psb_ld_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_fmt + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_to_fmt + +subroutine psb_ld_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_fmt + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_from_fmt + + +subroutine psb_ld_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_to_coo + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + call b%set_nzeros(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call b%set_host() + call a%free() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_mv_coo_to_coo + +subroutine psb_ld_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_from_coo + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + call a%set_nzeros(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_mv_coo_from_coo + + +subroutine psb_ld_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_to_fmt + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_mv_coo_to_fmt + +subroutine psb_ld_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_mv_coo_from_fmt + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_mv_coo_from_fmt + +subroutine psb_ld_coo_cp_from(a,b) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_cp_from + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + type(psb_ld_coo_sparse_mat), intent(in) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_cp_from + +subroutine psb_ld_coo_mv_from(a,b) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_coo_mv_from + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + type(psb_ld_coo_sparse_mat), intent(inout) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_coo_mv_from + + + +subroutine psb_ld_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_fix_coo + implicit none + + class(psb_ld_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + integer(psb_lpk_), allocatable :: iaux(:) + !locals + integer(psb_lpk_) :: nza, nzl,iret, nra, nca + integer(psb_lpk_) :: i,j, irw, icl + integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + if (a%is_dev()) call a%sync() + + nra = a%get_nrows() + nca = a%get_ncols() + nza = a%get_nzeros() + if (nza >= 2) then + dupl_ = a%get_dupl() + call psb_ld_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + else + i = nza + end if + call a%set_sort_status(idir_) + call a%set_nzeros(i) + call a%set_asb() + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_fix_coo + + + +subroutine psb_ld_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + use psb_sort_mod + implicit none + + integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + real(psb_dpk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + !locals + integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) + real(psb_dpk_), allocatable :: vs(:) + integer(psb_lpk_) :: nza + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin + integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + logical :: srt_inp, use_buffers + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + + + if (nzin < 2) then + call psb_erractionrestore(err_act) + return + end if + + dupl_ = dupl + + + + allocate(iaux(max(nr,nc,nzin)+2),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) + use_buffers = (info == 0) + + select case(idir_) + + case(psb_row_major_) + ! Row major order + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + iaux(:) = 0 + iaux(ia(1)) = iaux(ia(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ia(i) < 1).or.(ia(i)> nr)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ia(i)) = iaux(ia(i)) + 1 + srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) + end do + else + use_buffers=.false. + end if + end if + ! Check again use_buffers. + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major + ! we can do it row-by-row here. + k = 0 + i = 1 + do j=1, nr + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ja(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already row-major + ! we have to sort all + + ip = iaux(1) + iaux(1) = 0 + do i=2, nr + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nr+1) = ip + + do i=1,nzin + irw = ia(i) + ip = iaux(irw) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(irw) = ip + end do + k = 0 + i = 1 + do j=1, nr + + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,jas(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + ! + ! If we did not have enough memory for buffers, + ! let's try in place. + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + endif + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + + case(psb_col_major_) + + if (use_buffers) then + iaux(:) = 0 + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + iaux(ja(1)) = iaux(ja(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ja(i) < 1).or.(ja(i)> nc)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ja(i)) = iaux(ja(i)) + 1 + srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) + end do + else + use_buffers=.false. + end if + end if + !use_buffers=use_buffers.and.srt_inp + ! Check again use_buffers. + if (use_buffers) then + + if (srt_inp) then + ! If input was already col-major + ! we can do it col-by-col here. + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ia(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already col-major + ! we have to sort all + ip = iaux(1) + iaux(1) = 0 + do i=2, nc + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nc+1) = ip + + do i=1,nzin + icl = ja(i) + ip = iaux(icl) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(icl) = ip + end do + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ias(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + end if + + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_fix_coo_inner + + +subroutine psb_ld_cp_coo_to_icoo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_to_icoo + implicit none + class(psb_ld_coo_sparse_mat), intent(in) :: a + class(psb_d_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_base_sparse_mat = a%psb_lbase_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_to_icoo + +subroutine psb_ld_cp_coo_from_icoo(a,b,info) + use psb_error_mod + use psb_d_base_mat_mod, psb_protect_name => psb_ld_cp_coo_from_icoo + implicit none + class(psb_ld_coo_sparse_mat), intent(inout) :: a + class(psb_d_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lbase_sparse_mat = b%psb_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index 4b46bc9a2..c70868b12 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -2030,7 +2030,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2059,7 +2059,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2098,7 +2098,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2122,7 +2122,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2951,3 +2951,1901 @@ contains end subroutine csc_spspmm end subroutine psb_dcscspspmm + + + +subroutine psb_ld_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_get_diag + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = done + else + do i=1, mnm + d(i) = dzero + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + endif + do i=mnm+1,size(d) + d(i) = dzero + end do + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_get_diag + + +subroutine psb_ld_csc_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_scal + use psb_string_mod + implicit none + class(psb_ld_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, n + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act,ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + if (a%is_unit()) then + call a%make_nonunit() + end if + + left = (side_ == 'L') + + if (left) then + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, a%get_nzeros() + a%val(i) = a%val(i) * d(a%ia(i)) + enddo + else + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do j=1, n + do i = a%icp(j), a%icp(j+1) -1 + a%val(i) = a%val(i) * d(j) + end do + enddo + end if + call a%set_host() + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_scal + + +subroutine psb_ld_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_scals + implicit none + class(psb_ld_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act,ierr(5) + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_scals + + +function psb_ld_csc_maxval(a) result(res) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_maxval + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: nnz + character(len=20) :: name='ld_csc_maxval' + logical, parameter :: debug=.false. + + + if (a%is_unit()) then + res = done + else + res = dzero + end if + if (a%is_dev()) call a%sync() + + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_ld_csc_maxval + +function psb_ld_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csnm1 + + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_csc_csnm1' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + m = a%get_nrows() + n = a%get_ncols() + is_unit = a%is_unit() + do j=1, n + if (is_unit) then + acc = done + else + acc = dzero + end if + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_ld_csc_csnm1 + +subroutine psb_ld_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_colsum + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = done + else + d(i) = dzero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_colsum + +subroutine psb_ld_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_aclsum + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_lpk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = done + else + d(i) = dzero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, a%get_ncols() + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_aclsum + +subroutine psb_ld_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_rowsum + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_rowsum + +subroutine psb_ld_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_arwsum + class(psb_ld_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_arwsum + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_ld_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csgetptn + implicit none + + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + + end subroutine lcsc_getptn + +end subroutine psb_ld_csc_csgetptn + + + + +subroutine psb_ld_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csgetrow + implicit none + + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + call psb_ensure_size(int(1.25*nzin_)+ione,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + call psb_ensure_size(int(1.25*nzin_)+ione,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + end subroutine lcsc_getrow + +end subroutine psb_ld_csc_csgetrow + + + +subroutine psb_ld_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csput_a + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5) + character(len=20) :: name='ld_csc_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + ierr(1)=1 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=3 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=4 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_ld_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_ld_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng, nar, nac + integer(psb_ipk_) :: debug_level, debug_unit, inr + character(len=20) :: name='ld_csc_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nar = a%get_nrows() + nac = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_ld_csc_srch_upd + +end subroutine psb_ld_csc_csput_a + + +subroutine psb_ld_cp_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_cp_csc_from_coo + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! We need to make a copy because mv_from will have to + ! sort in column-major order. + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_ld_cp_csc_from_coo + + + +subroutine psb_ld_cp_csc_to_coo(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_cp_csc_to_coo + implicit none + + class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ia(j) = a%ia(j) + b%ja(j) = i + b%val(j) = a%val(j) + end do + end do + + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_ld_cp_csc_to_coo + + +subroutine psb_ld_mv_csc_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_mv_csc_to_coo + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ia,b%ia) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ja,info) + if (info /= psb_success_) return + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ja(j) = i + end do + end do + call a%free() + call b%fix(info) + +end subroutine psb_ld_mv_csc_to_coo + + +subroutine psb_ld_mv_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_mv_csc_from_coo + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, i,j,k,ip,irw, nc, nrl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name='ld_mv_csc_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info, idir=psb_col_major_) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ja,itemp) + call move_alloc(b%ia,a%ia) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%icp,info) + call b%free() + + a%icp(:) = 0 + do k=1,nza + i = itemp(k) + a%icp(i) = a%icp(i) + 1 + end do + ip = 1 + do i=1,nc + nrl = a%icp(i) + a%icp(i) = ip + ip = ip + nrl + end do + a%icp(nc+1) = ip + call a%set_host() + + +end subroutine psb_ld_mv_csc_from_coo + + +subroutine psb_ld_mv_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_mv_csc_to_fmt + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_ld_csc_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call move_alloc(a%icp, b%icp) + call move_alloc(a%ia, b%ia) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ld_mv_csc_to_fmt +!!$ + +subroutine psb_ld_cp_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_cp_csc_to_fmt + implicit none + + class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_ld_csc_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + nc = a%get_ncols() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ld_cp_csc_to_fmt + + +subroutine psb_ld_mv_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_mv_csc_from_fmt + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_ld_csc_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + call a%set_host() + +end subroutine psb_ld_mv_csc_from_fmt + + + +subroutine psb_ld_cp_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_cp_csc_from_fmt + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_ld_csc_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + nc = b%get_ncols() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + call a%set_host() + +end subroutine psb_ld_cp_csc_from_fmt + + +subroutine psb_ld_csc_mold(a,b,info) + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_mold + use psb_error_mod + implicit none + class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csc_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ld_csc_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_mold + +subroutine psb_ld_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_reallocate_nz + implicit none + integer(psb_ipk_), intent(in) :: nz + class(psb_ld_csc_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='ld_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ia,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,& + & a%get_ncols()+1), a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_reallocate_nz + + + +subroutine psb_ld_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_csgetblk + implicit none + + class(psb_ld_csc_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_csgetblk + +subroutine psb_ld_csc_reinit(a,clear) + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_reinit + implicit none + + class(psb_ld_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_reinit + +subroutine psb_ld_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_trim + implicit none + class(psb_ld_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, n + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + n = a%get_ncols() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_trim + +subroutine psb_ld_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csc_allocate_mnnz + +subroutine psb_ld_csc_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_d_csc_mat_mod, psb_protect_name => psb_ld_csc_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='ld_csc_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_ld_csc_print + +subroutine psb_ldcscspspmm(a,b,c,info) + use psb_d_mat_mod + use psb_serial_mod, psb_protect_name => psb_ldcscspspmm + + implicit none + + class(psb_ld_csc_sparse_mat), intent(in) :: a,b + type(psb_ld_csc_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_cscspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + + call csc_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csc_spspmm(a,b,c,info) + implicit none + type(psb_ld_csc_sparse_mat), intent(in) :: a,b + type(psb_ld_csc_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: icol(:), idxs(:), iaux(:) + real(psb_dpk_), allocatable :: col(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + real(psb_dpk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ia)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,col,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,icol,info) + if (info /= 0) return + col = dzero + icol = 0 + nzc = 1 + do j = 1,nb + c%icp(j) = nzc + nrc = 0 + do k = b%icp(j), b%icp(j+1)-1 + icl = b%ia(k) + cfb = b%val(k) + irwsz = a%icp(icl+1)-a%icp(icl) + do i = a%icp(icl),a%icp(icl+1)-1 + irw = a%ia(i) + if (icol(irw) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ia,info) + if (info /= 0) return + end if + call psb_msort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) + col(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%icp(nb+1) = nzc + + end subroutine csc_spspmm + +end subroutine psb_ldcscspspmm diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index 868f0fe69..8edbf43c7 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -1018,7 +1018,6 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans) real(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_csr_cssm' logical, parameter :: debug=.false. @@ -1269,8 +1268,8 @@ function psb_d_csr_maxval(a) result(res) class(psb_d_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: info character(len=20) :: name='d_csr_maxval' logical, parameter :: debug=.false. @@ -1295,7 +1294,6 @@ function psb_d_csr_csnmi(a) result(res) real(psb_dpk_) :: acc logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_csnmi' logical, parameter :: debug=.false. @@ -1655,7 +1653,6 @@ subroutine psb_d_csr_scals(d,a,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -1704,7 +1701,6 @@ subroutine psb_d_csr_reallocate_nz(nz,a) integer(psb_ipk_), intent(in) :: nz class(psb_d_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_csr_reallocate_nz' logical, parameter :: debug=.false. @@ -1736,7 +1732,6 @@ subroutine psb_d_csr_mold(a,b,info) class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csr_mold' logical, parameter :: debug=.false. @@ -1846,7 +1841,6 @@ subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2021,7 +2015,6 @@ subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_, chksz_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2206,8 +2199,6 @@ subroutine psb_d_csr_tril(a,l,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_), allocatable :: ia(:), ja(:) - real(psb_dpk_), allocatable :: val(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ @@ -2362,8 +2353,6 @@ subroutine psb_d_csr_triu(a,u,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_), allocatable :: ia(:), ja(:) - real(psb_dpk_), allocatable :: val(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ @@ -2515,7 +2504,6 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_csr_csput_a' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit @@ -2527,28 +2515,24 @@ subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) debug_level = psb_get_debug_level() if (nz <= 0) then - info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_iarg_neg_; i=1 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=2 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=3 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=4 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if @@ -2652,7 +2636,7 @@ contains i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2680,7 +2664,7 @@ contains i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2720,7 +2704,7 @@ contains i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2742,7 +2726,7 @@ contains i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2776,7 +2760,6 @@ subroutine psb_d_csr_reinit(a,clear) logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -2821,7 +2804,6 @@ subroutine psb_d_csr_trim(a) implicit none class(psb_d_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz, m - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -2856,7 +2838,6 @@ subroutine psb_d_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='d_csr_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='real' @@ -3446,3 +3427,2179 @@ contains end subroutine csr_spspmm end subroutine psb_dcsrspspmm + + +! +! +! ld version +! +! +subroutine psb_ld_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_get_diag + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = done + else + do i=1, mnm + d(i) = dzero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = dzero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ld_csr_get_diag + + +subroutine psb_ld_csr_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_scal + use psb_string_mod + implicit none + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ld_csr_scal + + +subroutine psb_ld_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_scals + implicit none + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ld_csr_scals + + +function psb_ld_csr_maxval(a) result(res) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_maxval + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: nnz + integer(psb_ipk_) :: info + character(len=20) :: name='ld_csr_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_ld_csr_maxval + +function psb_ld_csr_csnmi(a) result(res) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csnmi + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nr, ir, jc, nc + real(psb_dpk_) :: acc + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_ld_csr_csnmi + +subroutine psb_ld_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_rowsum + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_rowsum + +subroutine psb_ld_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_arwsum + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_arwsum + +subroutine psb_ld_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_colsum + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_colsum + +subroutine psb_ld_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_aclsum + class(psb_ld_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_aclsum + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_ld_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_reallocate_nz + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='ld_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_reallocate_nz + +subroutine psb_ld_csr_mold(a,b,info) + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_mold + use psb_error_mod + implicit none + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csr_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ld_csr_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ld_csr_mold + +subroutine psb_ld_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_allocate_mnnz + + +subroutine psb_ld_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csgetptn + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_ld_csr_csgetrow + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_ld_csr_tril + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end if + end do + end do + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + l%val(nzin) = val(k) + end if + end if + end do + end do + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_tril + +subroutine psb_ld_csr_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_triu + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ld_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) + end if + end if + end do + end do + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_triu + + +subroutine psb_ld_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_csput_a + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_csr_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + + call psb_erractionsave(err_act) + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (nz <= 0) then + info = psb_err_iarg_neg_; + call psb_errpush(info,name,m_err=(/1/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/2/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/3/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/4/)) + goto 9999 + end if + + if (nz == 0) return + if (a%is_dev()) call a%sync() + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_ld_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_ld_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,ng + integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc + character(len=20) :: name='ld_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_ld_csr_srch_upd + +end subroutine psb_ld_csr_csput_a + + +subroutine psb_ld_csr_reinit(a,clear) + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_reinit + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = dzero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_reinit + +subroutine psb_ld_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_trim + implicit none + class(psb_ld_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csr_trim + +subroutine psb_ld_csr_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_csr_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ld_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ld_csr_print' + logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_ld_csr_print + + +subroutine psb_ld_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_from_coo + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_ld_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k,ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='ld_cp_csr_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_ld_base_sparse_mat = tmp%psb_ld_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + + +end subroutine psb_ld_cp_csr_from_coo + + + +subroutine psb_ld_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_to_coo + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_ld_cp_csr_to_coo + + +subroutine psb_ld_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_to_coo + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,k,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_ld_mv_csr_to_coo + + + +subroutine psb_ld_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_from_coo + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k, ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='mv_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + +end subroutine psb_ld_mv_csr_from_coo + + +subroutine psb_ld_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_to_fmt + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_ld_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ld_mv_csr_to_fmt + + +subroutine psb_ld_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_to_fmt + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_ld_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ld_base_sparse_mat = a%psb_ld_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ld_cp_csr_to_fmt + + +subroutine psb_ld_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_mv_csr_from_fmt + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_ld_csr_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_ld_mv_csr_from_fmt + + + +subroutine psb_ld_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_d_base_mat_mod + use psb_realloc_mod + use psb_d_csr_mat_mod, psb_protect_name => psb_ld_cp_csr_from_fmt + implicit none + + class(psb_ld_csr_sparse_mat), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ld_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ld_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_ld_csr_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_ld_base_sparse_mat = b%psb_ld_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_ld_cp_csr_from_fmt + +subroutine psb_ldcsrspspmm(a,b,c,info) + use psb_d_mat_mod + use psb_serial_mod, psb_protect_name => psb_ldcsrspspmm + + implicit none + + class(psb_ld_csr_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_ld_csr_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: irow(:), idxs(:) + real(psb_dpk_), allocatable :: row(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + real(psb_dpk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + + + end subroutine csr_spspmm + +end subroutine psb_ldcsrspspmm + diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 410fc5930..a2f960ad1 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -37,8 +37,6 @@ ! for actually executing the method. ! ! -! - ! == =================================== @@ -2434,5 +2432,2423 @@ subroutine psb_d_scals(d,a,info) end subroutine psb_d_scals +subroutine psb_d_mv_from_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_mv_from_lb + implicit none + + class(psb_dspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%mv_from_lfmt(b,info) + +end subroutine psb_d_mv_from_lb + + +subroutine psb_d_cp_from_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cp_from_lb + implicit none + + class(psb_dspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%cp_from_lfmt(b,info) + +end subroutine psb_d_cp_from_lb + +subroutine psb_d_mv_to_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_mv_to_lb + implicit none + + class(psb_dspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%mv_to_lfmt(b,info) + call a%free() + end if + +end subroutine psb_d_mv_to_lb + +subroutine psb_d_cp_to_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cp_to_lb + implicit none + class(psb_dspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%cp_to_lfmt(b,info) + end if + +end subroutine psb_d_cp_to_lb + +subroutine psb_d_mv_from_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_mv_from_l + implicit none + class(psb_dspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info) + call a%a%mv_from_lfmt(b%a,info) + else + call a%free() + end if + call b%free() + +end subroutine psb_d_mv_from_l + + +subroutine psb_d_cp_from_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cp_from_l + implicit none + + class(psb_dspmat_type), intent(out) :: a + class(psb_ldspmat_type), intent(in) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_d_csr_sparse_mat :: a%a, stat=info) + call a%a%cp_from_lfmt(b%a,info) + else + call a%free() + end if +end subroutine psb_d_cp_from_l + +subroutine psb_d_mv_to_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_mv_to_l + implicit none + + class(psb_dspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_ld_csr_sparse_mat :: b%a, stat=info) + call a%a%mv_to_lfmt(b%a,info) + else + call b%free() + end if + call a%free() + +end subroutine psb_d_mv_to_l + +subroutine psb_d_cp_to_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_d_cp_to_l + implicit none + + class(psb_dspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_ld_csr_sparse_mat :: b%a, stat=info) + call a%a%cp_to_lfmt(b%a,info) + else + call b%free() + end if + +end subroutine psb_d_cp_to_l +! +! +! ld versions +! + + +subroutine psb_ld_set_nrows(m,a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_nrows + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_nrows + + +subroutine psb_ld_set_ncols(n,a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_ncols + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_ncols + + + +! +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ +! + +subroutine psb_ld_set_dupl(n,a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_dupl + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_dupl + + +! +! Set the STATE of the internal matrix object +! + +subroutine psb_ld_set_null(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_null + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_null + + +subroutine psb_ld_set_bld(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_bld + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_bld + + +subroutine psb_ld_set_upd(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_upd + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ld_set_upd + + +subroutine psb_ld_set_asb(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_asb + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_asb + + +subroutine psb_ld_set_sorted(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_sorted + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_sorted + + +subroutine psb_ld_set_triangle(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_triangle + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_triangle + + +subroutine psb_ld_set_unit(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_unit + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_unit + + +subroutine psb_ld_set_lower(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_lower + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_lower + + +subroutine psb_ld_set_upper(a,val) + use psb_d_mat_mod, psb_protect_name => psb_ld_set_upper + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_ld_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_d_mat_mod, psb_protect_name => psb_ld_sparse_print + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,head,ivr,ivc) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_sparse_print + + +subroutine psb_ld_n_sparse_print(fname,a,iv,head,ivr,ivc) + use psb_d_mat_mod, psb_protect_name => psb_ld_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info, iout + logical :: isopen + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call a%a%print(iout,iv,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_n_sparse_print + + +subroutine psb_ld_get_neigh(a,idx,neigh,n,info,lev) + use psb_d_mat_mod, psb_protect_name => psb_ld_get_neigh + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_get_neigh + + + +subroutine psb_ld_csall(nr,nc,a,info,nz) + use psb_d_mat_mod, psb_protect_name => psb_ld_csall + use psb_d_base_mat_mod + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + call a%free() + + info = psb_success_ + allocate(psb_ld_coo_sparse_mat :: a%a, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csall + + +subroutine psb_ld_reallocate_nz(nz,a) + use psb_d_mat_mod, psb_protect_name => psb_ld_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_reallocate_nz + + +subroutine psb_ld_free(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_free + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_ld_free + + +subroutine psb_ld_trim(a) + use psb_d_mat_mod, psb_protect_name => psb_ld_trim + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_trim + + + +subroutine psb_ld_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_mat_mod, psb_protect_name => psb_ld_csput_a + use psb_d_base_mat_mod + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_a' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csput_a + +subroutine psb_ld_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_d_mat_mod, psb_protect_name => psb_ld_csput_v + use psb_d_base_mat_mod + use psb_d_vect_mod, only : psb_d_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + use psb_error_mod + implicit none + class(psb_ldspmat_type), intent(inout) :: a + type(psb_d_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csput_v + + +subroutine psb_ld_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_csgetptn + implicit none + + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csgetptn + + +subroutine psb_ld_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_csgetrow + implicit none + + class(psb_ldspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csgetrow + + + + +subroutine psb_ld_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_csgetblk + implicit none + + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + logical :: append_ + type(psb_ld_coo_sparse_mat), allocatable :: acoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(append)) then + append_ = append + else + append_ = .false. + end if + + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then + if (allocated(b%a)) & + & call b%a%mv_to_coo(acoo,info) + end if + + if (info == psb_success_) then + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csgetblk + + +subroutine psb_ld_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_tril + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ldspmat_type), optional, intent(inout) :: u + + integer(psb_ipk_) :: err_act + character(len=20) :: name='tril' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat), allocatable :: lcoo, ucoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(lcoo,stat=info) + call l%free() + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ld_tril + +subroutine psb_ld_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_triu + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ldspmat_type), optional, intent(inout) :: l + + integer(psb_ipk_) :: err_act + character(len=20) :: name='triu' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat), allocatable :: lcoo, ucoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ucoo,stat=info) + call u%free() + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ld_triu + + +subroutine psb_ld_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_csclip + implicit none + + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_ld_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + call b%free() + if (info == psb_success_) then + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_csclip + + +subroutine psb_ld_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_d_base_mat_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_b_csclip + implicit none + + class(psb_ldspmat_type), intent(in) :: a + type(psb_ld_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_b_csclip + + + + +subroutine psb_ld_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cscnv + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_ld_base_sparse_mat), intent(in), optional :: mold + + + class(psb_ld_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_ld_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_ld_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_ld_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(dupl)) then + call altmp%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call altmp%set_dupl(psb_dupl_def_) + end if + + if (debug) write(psb_err_unit,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%trim() + call b%asb() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cscnv + + + +subroutine psb_ld_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cscnv_ip + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_ld_base_sparse_mat), intent(in), optional :: mold + + + class(psb_ld_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_ld_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_ld_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_ld_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cscnv_ip + + + +subroutine psb_ld_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cscnv_base + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + + + type(psb_ld_coo_sparse_mat) :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == psb_success_).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_cscnv_base + + + +!!$subroutine psb_ld_clip_d(a,b,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_d_base_mat_mod +!!$ use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d +!!$ implicit none +!!$ +!!$ class(psb_ldspmat_type), intent(in) :: a +!!$ class(psb_ldspmat_type), intent(inout) :: b +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_ld_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call b%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_ld_clip_d +!!$ +!!$ +!!$ +!!$subroutine psb_ld_clip_d_ip(a,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_d_base_mat_mod +!!$ use psb_d_mat_mod, psb_protect_name => psb_ld_clip_d_ip +!!$ implicit none +!!$ +!!$ class(psb_ldspmat_type), intent(inout) :: a +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_ld_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call a%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_ld_clip_d_ip +!!$ + +subroutine psb_ld_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_mv_from + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call a%free() + allocate(a%a,mold=b, stat=info) + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_ld_mv_from + + +subroutine psb_ld_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cp_from + implicit none + class(psb_ldspmat_type), intent(out) :: a + class(psb_ld_base_sparse_mat), intent(in) :: b + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + call a%free() + ! + ! Note: it is tempting to use SOURCE allocation below; + ! however this would run the risk of messing up with data + ! allocated externally (e.g. GPU-side data). + ! + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ld_cp_from + + +subroutine psb_ld_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_mv_to + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_ld_mv_to + + +subroutine psb_ld_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cp_to + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ld_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_ld_cp_to + +subroutine psb_ld_mold(a,b) + use psb_d_mat_mod, psb_protect_name => psb_ld_mold + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), allocatable, intent(out) :: b + integer(psb_ipk_) :: info + + allocate(b,mold=a%a, stat=info) + +end subroutine psb_ld_mold + +subroutine psb_ldspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ldspmat_type_move + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call b%free() + call move_alloc(a%a,b%a) + + return +end subroutine psb_ldspmat_type_move + + +subroutine psb_ldspmat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ldspmat_clone + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ldspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ldspmat_clone + + +subroutine psb_ld_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_transp_1mat + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_transp_1mat + + + +subroutine psb_ld_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_transp_2mat + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_transp_2mat + + +subroutine psb_ld_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_transc_1mat + implicit none + class(psb_ldspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_transc_1mat + + + +subroutine psb_ld_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_transc_2mat + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_ldspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_transc_2mat + + +subroutine psb_ld_asb(a,mold) + use psb_d_mat_mod, psb_protect_name => psb_ld_asb + use psb_error_mod + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + class(psb_ld_base_sparse_mat), optional, intent(in) :: mold + class(psb_ld_base_sparse_mat), allocatable :: tmp + class(psb_ld_base_sparse_mat), pointer :: mld + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='ld_asb' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_ld_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_asb + +subroutine psb_ld_reinit(a,clear) + use psb_d_mat_mod, psb_protect_name => psb_ld_reinit + use psb_error_mod + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (a%a%has_update()) then + call a%a%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_reinit + + + + +function psb_ld_get_diag(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_get_diag + + +subroutine psb_ld_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_scal + implicit none + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info,side=side) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_scal + + +subroutine psb_ld_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_scals + implicit none + class(psb_ldspmat_type), intent(inout) :: a + real(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ld_scals + +function psb_ld_maxval(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_ld_maxval + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%maxval() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_maxval + +function psb_ld_csnmi(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_ld_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnmi() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_csnmi + +function psb_ld_csnm1(a) result(res) + use psb_d_mat_mod, psb_protect_name => psb_ld_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnm1() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_csnm1 + + +function psb_ld_rowsum(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + call a%a%rowsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_rowsum + +function psb_ld_arwsum(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%arwsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_arwsum + +function psb_ld_colsum(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%colsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_colsum + +function psb_ld_aclsum(a,info) result(d) + use psb_d_mat_mod, psb_protect_name => psb_ld_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ldspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%aclsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ld_aclsum + +subroutine psb_ld_mv_from_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_mv_from_ib + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + if (.not.allocated(a%a)) allocate(psb_ld_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%mv_from_ifmt(b,info) + +end subroutine psb_ld_mv_from_ib + +subroutine psb_ld_cp_from_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cp_from_ib + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) allocate(psb_ld_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%cp_from_ifmt(b,info) + +end subroutine psb_ld_cp_from_ib + +subroutine psb_ld_mv_to_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_mv_to_ib + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%mv_to_ifmt(b,info) + call a%free() + end if + +end subroutine psb_ld_mv_to_ib + +subroutine psb_ld_cp_to_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cp_to_ib + implicit none + class(psb_ldspmat_type), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%cp_to_ifmt(b,info) + end if + +end subroutine psb_ld_cp_to_ib + +subroutine psb_ld_mv_from_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_mv_from_i + implicit none + class(psb_ldspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_ld_csr_sparse_mat :: a%a, stat=info) + call a%a%mv_from_ifmt(b%a,info) + else + call a%free() + end if + call b%free() + +end subroutine psb_ld_mv_from_i + + +subroutine psb_ld_cp_from_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cp_from_i + implicit none + + class(psb_ldspmat_type), intent(out) :: a + class(psb_dspmat_type), intent(in) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_ld_csr_sparse_mat :: a%a, stat=info) + call a%a%cp_from_ifmt(b%a,info) + else + call a%free() + end if +end subroutine psb_ld_cp_from_i + +subroutine psb_ld_mv_to_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_mv_to_i + implicit none + + class(psb_ldspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_d_csr_sparse_mat :: b%a, stat=info) + call a%a%mv_to_ifmt(b%a,info) + else + call b%free() + end if + call a%free() + +end subroutine psb_ld_mv_to_i + +subroutine psb_ld_cp_to_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_d_mat_mod, psb_protect_name => psb_ld_cp_to_i + implicit none + + class(psb_ldspmat_type), intent(in) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_d_csr_sparse_mat :: b%a, stat=info) + call a%a%cp_to_ifmt(b%a,info) + else + call b%free() + end if + +end subroutine psb_ld_cp_to_i + + + + diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index aaef8dfb7..48733b745 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -50,8 +50,7 @@ subroutine psb_s_base_cp_to_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -75,8 +74,7 @@ subroutine psb_s_base_cp_from_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -101,8 +99,7 @@ subroutine psb_s_base_cp_to_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp @@ -144,8 +141,7 @@ subroutine psb_s_base_cp_from_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp @@ -190,8 +186,7 @@ subroutine psb_s_base_mv_to_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -228,8 +223,7 @@ subroutine psb_s_base_mv_from_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -266,8 +260,7 @@ subroutine psb_s_base_mv_to_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp @@ -297,8 +290,7 @@ subroutine psb_s_base_mv_from_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_s_coo_sparse_mat) :: tmp @@ -344,8 +336,7 @@ subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csput' logical, parameter :: debug=.false. @@ -372,8 +363,7 @@ subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csput_v' integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ @@ -423,8 +413,7 @@ subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -439,8 +428,6 @@ subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end subroutine psb_s_base_csgetrow - - ! ! Here we have the base implementation of getblk and clip: ! this is just based on the getrow. @@ -462,10 +449,9 @@ subroutine psb_s_base_csgetblk(imin,imax,a,b,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csget' - integer(psb_ipk_) :: jmin_, jmax_ + integer(psb_ipk_) :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. @@ -554,8 +540,7 @@ subroutine psb_s_base_csclip(a,b,info,& integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb character(len=20) :: name='csget' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -649,7 +634,6 @@ subroutine psb_s_base_tril(a,l,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_spk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -801,7 +785,6 @@ subroutine psb_s_base_triu(a,u,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) real(psb_spk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -1000,8 +983,7 @@ subroutine psb_s_base_mold(a,b,info) class(psb_s_base_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='base_mold' logical, parameter :: debug=.false. @@ -1026,7 +1008,6 @@ subroutine psb_s_base_transp_2mat(a,b) type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='s_base_transp' call psb_erractionsave(err_act) @@ -1041,8 +1022,7 @@ subroutine psb_s_base_transp_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1)=ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1064,7 +1044,6 @@ subroutine psb_s_base_transc_2mat(a,b) type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='s_base_transc' call psb_erractionsave(err_act) @@ -1079,8 +1058,7 @@ subroutine psb_s_base_transc_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1) = ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1101,7 +1079,6 @@ subroutine psb_s_base_transp_1mat(a) type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='s_base_transp' call psb_erractionsave(err_act) @@ -1133,7 +1110,6 @@ subroutine psb_s_base_transc_1mat(a) type(psb_s_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='s_base_transc' call psb_erractionsave(err_act) @@ -1182,8 +1158,7 @@ subroutine psb_s_base_csmm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_csmm' logical, parameter :: debug=.false. @@ -1209,8 +1184,7 @@ subroutine psb_s_base_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_csmv' logical, parameter :: debug=.false. @@ -1237,8 +1211,7 @@ subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_inner_cssm' logical, parameter :: debug=.false. @@ -1264,8 +1237,7 @@ subroutine psb_s_base_inner_cssv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_inner_cssv' logical, parameter :: debug=.false. @@ -1296,7 +1268,6 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) real(psb_spk_), allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act, nar,nac,nc, i character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_cssm' logical, parameter :: debug=.false. @@ -1313,14 +1284,12 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) nc = min(size(x,2), size(y,2)) if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1340,8 +1309,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1364,8 +1332,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1389,8 +1356,7 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1404,16 +1370,13 @@ subroutine psb_s_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - end subroutine psb_s_base_cssm @@ -1430,9 +1393,8 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) real(psb_spk_), intent(in), optional :: d(:) real(psb_spk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='s_cssm' logical, parameter :: debug=.false. @@ -1449,14 +1411,12 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1476,8 +1436,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1495,8 +1454,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1520,8 +1478,7 @@ subroutine psb_s_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1580,8 +1537,7 @@ subroutine psb_s_base_scals(d,a,info) real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_scals' logical, parameter :: debug=.false. @@ -1607,8 +1563,7 @@ subroutine psb_s_base_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_scal' logical, parameter :: debug=.false. @@ -1623,8 +1578,6 @@ subroutine psb_s_base_scal(d,a,info,side) end subroutine psb_s_base_scal - - function psb_s_base_maxval(a) result(res) use psb_error_mod use psb_const_mod @@ -1634,8 +1587,7 @@ function psb_s_base_maxval(a) result(res) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='maxval' logical, parameter :: debug=.false. @@ -1662,8 +1614,7 @@ function psb_s_base_csnmi(a) result(res) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' real(psb_spk_), allocatable :: vt(:) @@ -1701,8 +1652,7 @@ function psb_s_base_csnm1(a) result(res) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' real(psb_spk_), allocatable :: vt(:) @@ -1737,8 +1687,7 @@ subroutine psb_s_base_rowsum(d,a) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1760,8 +1709,7 @@ subroutine psb_s_base_arwsum(d,a) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='arwsum' logical, parameter :: debug=.false. @@ -1783,8 +1731,7 @@ subroutine psb_s_base_colsum(d,a) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1806,8 +1753,7 @@ subroutine psb_s_base_aclsum(d,a) class(psb_s_base_sparse_mat), intent(in) :: a real(psb_spk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1822,7 +1768,6 @@ subroutine psb_s_base_aclsum(d,a) end subroutine psb_s_base_aclsum - subroutine psb_s_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod @@ -1833,8 +1778,7 @@ subroutine psb_s_base_get_diag(a,d,info) real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -1900,9 +1844,8 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) real(psb_spk_), allocatable :: tmp(:) class(psb_s_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='s_cssm' logical, parameter :: debug=.false. @@ -1919,14 +1862,12 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (x%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (y%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1949,8 +1890,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) @@ -1968,8 +1908,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1995,8 +1934,7 @@ subroutine psb_s_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -2034,8 +1972,7 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_inner_vect_sv' logical, parameter :: debug=.false. @@ -2059,3 +1996,2039 @@ subroutine psb_s_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) return end subroutine psb_s_base_inner_vect_sv + + +subroutine psb_s_base_cp_to_lcoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_cp_to_lcoo + +subroutine psb_s_base_cp_from_lcoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_lcoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_cp_from_lcoo + +subroutine psb_s_base_cp_to_lfmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: icoo + type(psb_ls_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%cp_to_lcoo(b,info) + class default + call a%cp_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call b%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_cp_to_lfmt + +subroutine psb_s_base_cp_from_lfmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_cp_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: icoo + type(psb_ls_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%cp_from_lcoo(b,info) + class default + call b%cp_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call a%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_cp_from_lfmt + + +subroutine psb_s_base_mv_to_lcoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_mv_to_lcoo + +subroutine psb_s_base_mv_from_lcoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lcoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_mv_from_lcoo + + +subroutine psb_s_base_mv_to_lfmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: icoo + type(psb_ls_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%mv_to_lcoo(b,info) + class default + call a%mv_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call b%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_mv_to_lfmt + +subroutine psb_s_base_mv_from_lfmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mv_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: icoo + type(psb_ls_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%mv_from_lcoo(b,info) + class default + call b%mv_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call a%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_base_mv_from_lfmt + +! +! +! ls implementation +! +! +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_ls_base_cp_to_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_cp_to_coo + +subroutine psb_ls_base_cp_from_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_cp_from_coo + + +subroutine psb_ls_base_cp_to_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_to_fmt + +subroutine psb_ls_base_cp_from_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_from_fmt + + +subroutine psb_ls_base_mv_to_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_to_coo + +subroutine psb_ls_base_mv_from_coo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_from_coo + + +subroutine psb_ls_base_mv_to_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_ls_base_mv_to_fmt + +subroutine psb_ls_base_mv_from_fmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_ls_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_ls_base_mv_from_fmt + +subroutine psb_ls_base_clean_zeros(a, info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_clean_zeros + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + ! + type(psb_ls_coo_sparse_mat) :: tmpcoo + + call a%mv_to_coo(tmpcoo,info) + if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call a%mv_from_coo(tmpcoo,info) + +end subroutine psb_ls_base_clean_zeros + + +subroutine psb_ls_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_a + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_csput_a + +subroutine psb_ls_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csput_v + use psb_s_base_vect_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + if (a%is_dev()) call a%sync() + if (val%is_dev()) call val%sync() + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_csput_v + +subroutine psb_ls_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csgetrow + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_csgetrow + + + +! +! Here we have the base implementation of getblk and clip: +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_ls_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csgetblk + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout + character(len=20) :: name='csget' + integer(psb_lpk_) :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + if (present(rscale)) then + rscale_=rscale + else + rscale_=.false. + end if + if (present(cscale)) then + cscale_=cscale + else + cscale_=.false. + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if (append_.and.(rscale_.or.cscale_)) then + write(psb_err_unit,*) & + & 'ls_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' + end if + + if (rscale_) then + call b%set_nrows(imax-imin+1) + else + call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) + end if + + if (cscale_) then + call b%set_ncols(jmax_-jmin_+1) + else + call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) + end if + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_csgetblk + + +subroutine psb_ls_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csclip + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_csclip + + +! +! Here we have the base implementation of tril and triu +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_ls_base_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_tril + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + real(psb_spk_), allocatable :: val(:) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + integer(psb_lpk_), parameter :: nbk=8 + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_, nbk + ibk = min(nbk,imax_-i+1) + call a%csget(i,i+ibk-1,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + if ((ja(k)-ia(k))<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = ia(k) + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = ia(k) + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end do + end do + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + do i=imin_,imax_ + k = min(jmax_,i+diag_) + call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& + & jmin=jmin_, jmax=k, append=.true., & + & nzin=nzin) + if (info /= psb_success_) goto 9999 + call l%set_nzeros(nzin+nzout) + nzin = nzin+nzout + end do + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_tril + +subroutine psb_ls_base_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_triu + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + real(psb_spk_), allocatable :: val(:) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + integer(psb_lpk_), parameter :: nbk=8 + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_, nbk + ibk = min(nbk,imax_-i+1) + call a%csget(i,i+ibk-1,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + if ((ja(k)-ia(k))= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_triu + + + +subroutine psb_ls_base_clone(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_clone + use psb_error_mod + implicit none + + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b, stat=info) + end if + if (info /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + + ! Do not use SOURCE allocation: this makes sure that + ! memory allocated elsewhere is treated properly. + allocate(b,mold=a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%cp_from_fmt(a, info) + +end subroutine psb_ls_base_clone + +subroutine psb_ls_base_make_nonunit(a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_make_nonunit + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + type(psb_ls_coo_sparse_mat) :: tmp + + integer(psb_ipk_) :: info + integer(psb_lpk_) :: i, j, m, n, nz, mnm + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) + if (info /= 0) return + m = tmp%get_nrows() + n = tmp%get_ncols() + mnm = min(m,n) + nz = tmp%get_nzeros() + call tmp%reallocate(nz+mnm) + do i=1, mnm + tmp%val(nz+i) = sone + tmp%ia(nz+i) = i + tmp%ja(nz+i) = i + end do + call tmp%set_nzeros(nz+mnm) + call tmp%set_unit(.false.) + call tmp%fix(info) + if (info /= 0) & + & call a%mv_from_coo(tmp,info) + end if + +end subroutine psb_ls_base_make_nonunit + +subroutine psb_ls_base_mold(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mold + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_mold' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_mold + +subroutine psb_ls_base_transp_2mat(a,b) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ls_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_ls_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_transp_2mat + +subroutine psb_ls_base_transc_2mat(a,b) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transc_2mat + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ls_base_transc' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_ls_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ls_base_transc_2mat + +subroutine psb_ls_base_transp_1mat(a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_ls_base_sparse_mat), intent(inout) :: a + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ls_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_transp_1mat + +subroutine psb_ls_base_transc_1mat(a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_transc_1mat + implicit none + + class(psb_ls_base_sparse_mat), intent(inout) :: a + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='ls_base_transc' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_transc_1mat + +subroutine psb_ls_base_scals(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scals + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_scals' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_scals + +subroutine psb_ls_base_scal(d,a,info,side) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_scal + use psb_error_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_scal + +function psb_ls_base_maxval(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_maxval + + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + res = szero + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end function psb_ls_base_maxval + +function psb_ls_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csnmi + + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + real(psb_spk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = szero + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%arwsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_base_csnmi + +function psb_ls_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_csnm1 + + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + real(psb_spk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = szero + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%aclsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_base_csnm1 + +subroutine psb_ls_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_rowsum + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_rowsum + +subroutine psb_ls_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_arwsum + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_arwsum + +subroutine psb_ls_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_colsum + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_colsum + +subroutine psb_ls_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_aclsum + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_aclsum + +subroutine psb_ls_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_get_diag + + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_ls_base_get_diag + + + +subroutine psb_ls_base_cp_to_icoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_to_icoo + +subroutine psb_ls_base_cp_from_icoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_from_icoo + + +subroutine psb_ls_base_cp_to_ifmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: icoo + type(psb_ls_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_s_coo_sparse_mat) + call a%cp_to_icoo(b,info) + class default + call a%cp_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call b%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_to_ifmt + +subroutine psb_ls_base_cp_from_ifmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_cp_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: icoo + type(psb_ls_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_s_coo_sparse_mat) + call a%cp_from_icoo(b,info) + class default + call b%cp_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call a%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_cp_from_ifmt + + +subroutine psb_ls_base_mv_to_icoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_icoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_to_icoo + +subroutine psb_ls_base_mv_from_icoo(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_from_icoo + + +subroutine psb_ls_base_mv_to_ifmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: icoo + type(psb_ls_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_s_coo_sparse_mat) + call a%mv_to_icoo(b,info) + class default + call a%mv_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call b%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_to_ifmt + +subroutine psb_ls_base_mv_from_ifmt(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_base_mv_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_ls_base_sparse_mat), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_s_coo_sparse_mat) :: icoo + type(psb_ls_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_s_coo_sparse_mat) + call a%mv_from_icoo(b,info) + class default + call b%mv_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call a%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_base_mv_from_ifmt + + diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 index b80a8a996..849cc744b 100644 --- a/base/serial/impl/psb_s_coo_impl.f90 +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -29,7 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - subroutine psb_s_coo_get_diag(a,d,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_get_diag use psb_error_mod @@ -39,8 +38,7 @@ subroutine psb_s_coo_get_diag(a,d,info) real(psb_spk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -51,8 +49,7 @@ subroutine psb_s_coo_get_diag(a,d,info) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -88,8 +85,7 @@ subroutine psb_s_coo_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ logical :: left @@ -114,8 +110,7 @@ subroutine psb_s_coo_scal(d,a,info,side) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -127,8 +122,7 @@ subroutine psb_s_coo_scal(d,a,info,side) m = a%get_ncols() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -158,8 +152,7 @@ subroutine psb_s_coo_scals(d,a,info) real(psb_spk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -193,15 +186,16 @@ subroutine psb_s_coo_reallocate_nz(nz,a) implicit none integer(psb_ipk_), intent(in) :: nz class(psb_s_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='s_coo_reallocate_nz' logical, parameter :: debug=.false. call psb_erractionsave(err_act) nz_ = max(nz,ione) - call psb_realloc(nz_,a%ia,a%ja,a%val,info) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -224,8 +218,7 @@ subroutine psb_s_coo_mold(a,b,info) class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. @@ -259,8 +252,7 @@ subroutine psb_s_coo_reinit(a,clear) class(psb_s_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -306,8 +298,7 @@ subroutine psb_s_coo_trim(a) use psb_error_mod implicit none class(psb_s_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -363,8 +354,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) integer(psb_ipk_), intent(in) :: m,n class(psb_s_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='allocate_mnz' logical, parameter :: debug=.false. @@ -372,14 +362,12 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) info = psb_success_ if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif if (present(nz)) then @@ -389,8 +377,7 @@ subroutine psb_s_coo_allocate_mnnz(m,n,a,nz) end if if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 endif if (info == psb_success_) call psb_realloc(nz_,a%ia,info) @@ -431,13 +418,12 @@ subroutine psb_s_coo_print(iout,a,iv,head,ivr,ivc) character(len=*), optional :: head integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='real' - character(len=80) :: frmtv + character(len=80) :: frmtv integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' @@ -507,7 +493,7 @@ function psb_s_coo_get_nz_row(idx,a) result(res) nza = a%get_nzeros() if (a%is_by_rows()) then ! In this case we can do a binary search. - ip = psb_ibsrch(idx,nza,a%ia) + ip = psb_bsrch(idx,nza,a%ia) if (ip /= -1) return jp = ip do @@ -560,8 +546,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) real(psb_spk_) :: acc real(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_csmm' logical, parameter :: debug=.false. @@ -591,14 +576,12 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -916,8 +899,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) real(psb_spk_) :: acc real(psb_spk_), allocatable :: tmp(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_cssv_impl' logical, parameter :: debug=.false. @@ -941,14 +923,12 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if if (.not. (a%is_triangle())) then @@ -1260,8 +1240,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc real(psb_spk_) :: acc logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_csmv_impl' logical, parameter :: debug=.false. @@ -1295,16 +1274,15 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if + nnz = a%get_nzeros() if (alpha == szero) then @@ -1448,15 +1426,14 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_), intent(in) :: alpha, beta, x(:,:) real(psb_spk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans character :: trans_ integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc real(psb_spk_), allocatable :: acc(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_csmm_impl' logical, parameter :: debug=.false. @@ -1492,14 +1469,12 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -1652,8 +1627,7 @@ function psb_s_coo_maxval(a) result(res) class(psb_s_coo_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info character(len=20) :: name='s_coo_maxval' logical, parameter :: debug=.false. @@ -1684,7 +1658,6 @@ function psb_s_coo_csnmi(a) result(res) real(psb_spk_), allocatable :: vt(:) logical :: tra, is_unit integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_coo_csnmi' logical, parameter :: debug=.false. @@ -1746,7 +1719,6 @@ function psb_s_coo_csnm1(a) result(res) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_coo_csnm1' logical, parameter :: debug=.false. @@ -1785,7 +1757,6 @@ subroutine psb_s_coo_rowsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1793,10 +1764,10 @@ subroutine psb_s_coo_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() + if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1834,7 +1805,6 @@ subroutine psb_s_coo_arwsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1844,8 +1814,7 @@ subroutine psb_s_coo_arwsum(d,a) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1882,7 +1851,6 @@ subroutine psb_s_coo_colsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1892,8 +1860,7 @@ subroutine psb_s_coo_colsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if @@ -1931,7 +1898,6 @@ subroutine psb_s_coo_aclsum(d,a) real(psb_spk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1941,11 +1907,11 @@ subroutine psb_s_coo_aclsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if + if (a%is_unit()) then d = sone else @@ -1969,7 +1935,6 @@ subroutine psb_s_coo_aclsum(d,a) end subroutine psb_s_coo_aclsum - ! == ================================== ! ! @@ -2004,8 +1969,7 @@ subroutine psb_s_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, intent(in), optional :: rscale,cscale logical :: append_, rscale_, cscale_ - integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2121,7 +2085,7 @@ contains if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do - ip = psb_ibsrch(irw,nza,a%ia) + ip = psb_bsrch(irw,nza,a%ia) if (ip /= -1) exit irw = irw + 1 if (irw > imax) then @@ -2146,7 +2110,7 @@ contains end if do - jp = psb_ibsrch(lrw,nza,a%ia) + jp = psb_bsrch(lrw,nza,a%ia) if (jp /= -1) exit lrw = lrw - 1 if (irw > lrw) then @@ -2280,7 +2244,6 @@ subroutine psb_s_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_, chksz_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2404,7 +2367,7 @@ contains if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do - ip = psb_ibsrch(irw,nza,a%ia) + ip = psb_bsrch(irw,nza,a%ia) if (ip /= -1) exit irw = irw + 1 if (irw > imax) then @@ -2429,7 +2392,7 @@ contains end if do - jp = psb_ibsrch(lrw,nza,a%ia) + jp = psb_bsrch(lrw,nza,a%ia) if (jp /= -1) exit lrw = lrw - 1 if (irw > lrw) then @@ -2566,12 +2529,11 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='s_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2580,27 +2542,23 @@ subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (nz < 0) then info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 end if @@ -2760,7 +2718,7 @@ contains if ((ir > 0).and.(ir <= nr)) then ic = gtl(ic) if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2778,7 +2736,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2802,7 +2760,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2820,7 +2778,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2853,7 +2811,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2871,7 +2829,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2890,7 +2848,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2908,7 +2866,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2941,8 +2899,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -2984,8 +2941,7 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3031,8 +2987,7 @@ subroutine psb_s_cp_coo_to_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3064,8 +3019,7 @@ subroutine psb_s_cp_coo_from_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3099,8 +3053,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3142,8 +3095,7 @@ subroutine psb_s_mv_coo_from_coo(a,b,info) class(psb_s_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3187,8 +3139,7 @@ subroutine psb_s_mv_coo_to_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3220,8 +3171,7 @@ subroutine psb_s_mv_coo_from_fmt(a,b,info) class(psb_s_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3255,8 +3205,7 @@ subroutine psb_s_coo_cp_from(a,b) type(psb_s_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. @@ -3286,8 +3235,7 @@ subroutine psb_s_coo_mv_from(a,b) type(psb_s_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='mv_from' logical, parameter :: debug=.false. @@ -3324,7 +3272,6 @@ subroutine psb_s_fix_coo(a,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca integer(psb_ipk_) :: i,j, irw, icl, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' info = psb_success_ @@ -3375,6 +3322,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_s_base_mat_mod, psb_protect_name => psb_s_fix_coo_inner use psb_string_mod use psb_ip_reord_mod + use psb_sort_mod implicit none integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl @@ -3388,7 +3336,6 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_ integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers @@ -3461,7 +3408,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ja(i:imx),ix2,iret) + call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3572,7 +3519,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,jas(i:imx),ix2,iret) + call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3665,7 +3612,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! If we did not have enough memory for buffers, ! let's try in place. ! - call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret) + call psi_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3677,7 +3624,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret) + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3784,7 +3731,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ia(i:imx),ix2,iret) + call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3893,7 +3840,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ias(i:imx),ix2,iret) + call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3980,7 +3927,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret) + call psi_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3991,7 +3938,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret) + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -4082,3 +4029,3102 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_s_fix_coo_inner + +subroutine psb_s_cp_coo_to_lcoo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_to_lcoo + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lbase_sparse_mat = a%psb_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_s_cp_coo_to_lcoo + +subroutine psb_s_cp_coo_from_lcoo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_s_cp_coo_from_lcoo + implicit none + class(psb_s_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_base_sparse_mat = b%psb_lbase_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_s_cp_coo_from_lcoo + + +! +! +! ls coo impl +! +! + +subroutine psb_ls_coo_get_diag(a,d,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + if (a%is_unit()) then + d(1:mnm) = sone + else + d(1:mnm) = szero + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_get_diag + +subroutine psb_ls_coo_scal(d,a,info,side) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scal + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_scal + + +subroutine psb_ls_coo_scals(d,a,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_scals + + +function psb_ls_coo_maxval(a) result(res) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_maxval + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + character(len=20) :: name='s_coo_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + res = sone + else + res = szero + end if + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if + +end function psb_ls_coo_maxval + +function psb_ls_coo_csnmi(a) result(res) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnmi + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_coo_csnmi' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + is_unit = a%is_unit() + if (a%is_by_rows()) then + i = 1 + j = i + res = szero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + if (is_unit) then + acc = sone + else + acc = szero + end if + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + if (is_unit) then + vt = sone + else + vt = szero + end if + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_ls_coo_csnmi + + +function psb_ls_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csnm1 + + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_coo_csnm1' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + if (a%is_unit()) then + vt = sone + else + vt = szero + end if + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_ls_coo_csnm1 + +subroutine psb_ls_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_rowsum + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_rowsum + +subroutine psb_ls_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_arwsum + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_arwsum + +subroutine psb_ls_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_colsum + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_colsum + +subroutine psb_ls_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_aclsum + class(psb_ls_coo_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_aclsum + +subroutine psb_ls_coo_reallocate_nz(nz,a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='ls_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + nz_ = max(nz,ione) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_reallocate_nz + +subroutine psb_ls_coo_mold(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mold + use psb_error_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='coo_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ls_coo_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_mold + +subroutine psb_ls_coo_reinit(a,clear) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_reinit + use psb_error_mod + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_dev()) call a%sync() + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = szero + call a%set_host() + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_reinit + + + +subroutine psb_ls_coo_trim(a) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_trim + +subroutine psb_ls_coo_clean_zeros(a, info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_clean_zeros + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: info + ! + integer(psb_lpk_) :: i,j,k, nzin + + info = 0 + nzin = a%get_nzeros() + j = 0 + do i=1, nzin + if (a%val(i) /= szero) then + j = j + 1 + a%val(j) = a%val(i) + a%ia(j) = a%ia(i) + a%ja(j) = a%ja(i) + end if + end do + call a%set_nzeros(j) + call a%trim() +end subroutine psb_ls_coo_clean_zeros + + + +subroutine psb_ls_coo_allocate_mnnz(m,n,a,nz) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,izero/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(lzero) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + ! An empty matrix is sorted! + call a%set_sorted(.true.) + call a%set_host() + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_allocate_mnnz + + + +subroutine psb_ls_coo_print(iout,a,iv,head,ivr,ivc) + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_print + use psb_string_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_coo_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_ls_coo_print + + + + +function psb_ls_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_get_nz_row + implicit none + + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k + integer(psb_ipk_) :: inza + + if (a%is_dev()) call a%sync() + res = 0 + nza = a%get_nzeros() + if (a%is_by_rows()) then + ! In this case we can do a binary search. + inza = nza + ip = psb_bsrch(idx,inza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_ls_coo_get_nz_row + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_ls_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csgetptn + implicit none + + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_ls_coo_csgetptn + + +! +! NZ is the number of non-zeros on output. +! The output is guaranteed to be sorted +! +subroutine psb_ls_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csgetrow + implicit none + + class(psb_ls_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = iren(a%ia(i)) + ja(nzin_+nz) = iren(a%ja(i)) + end if + enddo + call psb_ls_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = a%ia(i) + ja(nzin_+nz) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + end if + call psb_ls_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + end if + + end subroutine coo_getrow + +end subroutine psb_ls_coo_csgetrow + + +subroutine psb_ls_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_csput_a + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_coo_csput_a_impl' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (nz < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + endif + isza = a%get_size() + if (isza < (nza+nz)) then + info = psb_err_alloc_dealloc_; call psb_errpush(info,name) + goto 9999 + end if + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + if (a%is_dev()) call a%sync() + + call ls_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_), intent(inout) :: aspk(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine ls_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nnz,dupl,ng, nr + integer(psb_ipk_) :: debug_level, debug_unit, innz, nc + character(len=20) :: name='ls_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + innz = nnz + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + endif + else + info = max(info,1) + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine ls_coo_srch_upd + +end subroutine psb_ls_coo_csput_a + + +subroutine psb_ls_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_coo + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_to_coo + +subroutine psb_ls_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_coo + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_from_coo + + +subroutine psb_ls_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_fmt + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_to_fmt + +subroutine psb_ls_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_fmt + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_from_fmt + + +subroutine psb_ls_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_to_coo + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + call b%set_nzeros(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call b%set_host() + call a%free() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_mv_coo_to_coo + +subroutine psb_ls_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_from_coo + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + call a%set_nzeros(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_mv_coo_from_coo + + +subroutine psb_ls_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_to_fmt + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_mv_coo_to_fmt + +subroutine psb_ls_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_mv_coo_from_fmt + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_mv_coo_from_fmt + +subroutine psb_ls_coo_cp_from(a,b) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_cp_from + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + type(psb_ls_coo_sparse_mat), intent(in) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_cp_from + +subroutine psb_ls_coo_mv_from(a,b) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_coo_mv_from + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + type(psb_ls_coo_sparse_mat), intent(inout) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_coo_mv_from + + + +subroutine psb_ls_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_fix_coo + implicit none + + class(psb_ls_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + integer(psb_lpk_), allocatable :: iaux(:) + !locals + integer(psb_lpk_) :: nza, nzl,iret, nra, nca + integer(psb_lpk_) :: i,j, irw, icl + integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + if (a%is_dev()) call a%sync() + + nra = a%get_nrows() + nca = a%get_ncols() + nza = a%get_nzeros() + if (nza >= 2) then + dupl_ = a%get_dupl() + call psb_ls_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + else + i = nza + end if + call a%set_sort_status(idir_) + call a%set_nzeros(i) + call a%set_asb() + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_fix_coo + + + +subroutine psb_ls_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + use psb_sort_mod + implicit none + + integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + real(psb_spk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + !locals + integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) + real(psb_spk_), allocatable :: vs(:) + integer(psb_lpk_) :: nza + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin + integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + logical :: srt_inp, use_buffers + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + + + if (nzin < 2) then + call psb_erractionrestore(err_act) + return + end if + + dupl_ = dupl + + + + allocate(iaux(max(nr,nc,nzin)+2),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) + use_buffers = (info == 0) + + select case(idir_) + + case(psb_row_major_) + ! Row major order + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + iaux(:) = 0 + iaux(ia(1)) = iaux(ia(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ia(i) < 1).or.(ia(i)> nr)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ia(i)) = iaux(ia(i)) + 1 + srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) + end do + else + use_buffers=.false. + end if + end if + ! Check again use_buffers. + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major + ! we can do it row-by-row here. + k = 0 + i = 1 + do j=1, nr + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ja(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already row-major + ! we have to sort all + + ip = iaux(1) + iaux(1) = 0 + do i=2, nr + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nr+1) = ip + + do i=1,nzin + irw = ia(i) + ip = iaux(irw) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(irw) = ip + end do + k = 0 + i = 1 + do j=1, nr + + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,jas(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + ! + ! If we did not have enough memory for buffers, + ! let's try in place. + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + endif + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + + case(psb_col_major_) + + if (use_buffers) then + iaux(:) = 0 + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + iaux(ja(1)) = iaux(ja(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ja(i) < 1).or.(ja(i)> nc)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ja(i)) = iaux(ja(i)) + 1 + srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) + end do + else + use_buffers=.false. + end if + end if + !use_buffers=use_buffers.and.srt_inp + ! Check again use_buffers. + if (use_buffers) then + + if (srt_inp) then + ! If input was already col-major + ! we can do it col-by-col here. + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ia(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already col-major + ! we have to sort all + ip = iaux(1) + iaux(1) = 0 + do i=2, nc + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nc+1) = ip + + do i=1,nzin + icl = ja(i) + ip = iaux(icl) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(icl) = ip + end do + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ias(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + end if + + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_fix_coo_inner + + +subroutine psb_ls_cp_coo_to_icoo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_to_icoo + implicit none + class(psb_ls_coo_sparse_mat), intent(in) :: a + class(psb_s_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_base_sparse_mat = a%psb_lbase_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_to_icoo + +subroutine psb_ls_cp_coo_from_icoo(a,b,info) + use psb_error_mod + use psb_s_base_mat_mod, psb_protect_name => psb_ls_cp_coo_from_icoo + implicit none + class(psb_ls_coo_sparse_mat), intent(inout) :: a + class(psb_s_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lbase_sparse_mat = b%psb_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index bf3fa900a..5f3137922 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -2030,7 +2030,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2059,7 +2059,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2098,7 +2098,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2122,7 +2122,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2951,3 +2951,1901 @@ contains end subroutine csc_spspmm end subroutine psb_scscspspmm + + + +subroutine psb_ls_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_get_diag + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = sone + else + do i=1, mnm + d(i) = szero + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + endif + do i=mnm+1,size(d) + d(i) = szero + end do + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_get_diag + + +subroutine psb_ls_csc_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_scal + use psb_string_mod + implicit none + class(psb_ls_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, n + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act,ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + if (a%is_unit()) then + call a%make_nonunit() + end if + + left = (side_ == 'L') + + if (left) then + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, a%get_nzeros() + a%val(i) = a%val(i) * d(a%ia(i)) + enddo + else + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do j=1, n + do i = a%icp(j), a%icp(j+1) -1 + a%val(i) = a%val(i) * d(j) + end do + enddo + end if + call a%set_host() + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_scal + + +subroutine psb_ls_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_scals + implicit none + class(psb_ls_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act,ierr(5) + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_scals + + +function psb_ls_csc_maxval(a) result(res) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_maxval + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: nnz + character(len=20) :: name='ls_csc_maxval' + logical, parameter :: debug=.false. + + + if (a%is_unit()) then + res = sone + else + res = szero + end if + if (a%is_dev()) call a%sync() + + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_ls_csc_maxval + +function psb_ls_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csnm1 + + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_csc_csnm1' + logical, parameter :: debug=.false. + + + res = szero + if (a%is_dev()) call a%sync() + m = a%get_nrows() + n = a%get_ncols() + is_unit = a%is_unit() + do j=1, n + if (is_unit) then + acc = sone + else + acc = szero + end if + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_ls_csc_csnm1 + +subroutine psb_ls_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_colsum + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = sone + else + d(i) = szero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_colsum + +subroutine psb_ls_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_aclsum + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_lpk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = sone + else + d(i) = szero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, a%get_ncols() + d(i) = d(i) + sone + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_aclsum + +subroutine psb_ls_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_rowsum + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_rowsum + +subroutine psb_ls_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_arwsum + class(psb_ls_csc_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = sone + else + d = szero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_arwsum + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_ls_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csgetptn + implicit none + + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + + end subroutine lcsc_getptn + +end subroutine psb_ls_csc_csgetptn + + + + +subroutine psb_ls_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csgetrow + implicit none + + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + call psb_ensure_size(int(1.25*nzin_)+ione,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + call psb_ensure_size(int(1.25*nzin_)+ione,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + end subroutine lcsc_getrow + +end subroutine psb_ls_csc_csgetrow + + + +subroutine psb_ls_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csput_a + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5) + character(len=20) :: name='ls_csc_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + ierr(1)=1 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=3 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=4 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_ls_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_ls_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng, nar, nac + integer(psb_ipk_) :: debug_level, debug_unit, inr + character(len=20) :: name='ls_csc_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nar = a%get_nrows() + nac = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_ls_csc_srch_upd + +end subroutine psb_ls_csc_csput_a + + +subroutine psb_ls_cp_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_cp_csc_from_coo + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! We need to make a copy because mv_from will have to + ! sort in column-major order. + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_ls_cp_csc_from_coo + + + +subroutine psb_ls_cp_csc_to_coo(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_cp_csc_to_coo + implicit none + + class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ia(j) = a%ia(j) + b%ja(j) = i + b%val(j) = a%val(j) + end do + end do + + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_ls_cp_csc_to_coo + + +subroutine psb_ls_mv_csc_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_mv_csc_to_coo + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ia,b%ia) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ja,info) + if (info /= psb_success_) return + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ja(j) = i + end do + end do + call a%free() + call b%fix(info) + +end subroutine psb_ls_mv_csc_to_coo + + +subroutine psb_ls_mv_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_mv_csc_from_coo + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, i,j,k,ip,irw, nc, nrl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name='ls_mv_csc_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info, idir=psb_col_major_) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ja,itemp) + call move_alloc(b%ia,a%ia) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%icp,info) + call b%free() + + a%icp(:) = 0 + do k=1,nza + i = itemp(k) + a%icp(i) = a%icp(i) + 1 + end do + ip = 1 + do i=1,nc + nrl = a%icp(i) + a%icp(i) = ip + ip = ip + nrl + end do + a%icp(nc+1) = ip + call a%set_host() + + +end subroutine psb_ls_mv_csc_from_coo + + +subroutine psb_ls_mv_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_mv_csc_to_fmt + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_ls_csc_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call move_alloc(a%icp, b%icp) + call move_alloc(a%ia, b%ia) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ls_mv_csc_to_fmt +!!$ + +subroutine psb_ls_cp_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_cp_csc_to_fmt + implicit none + + class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_ls_csc_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + nc = a%get_ncols() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ls_cp_csc_to_fmt + + +subroutine psb_ls_mv_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_mv_csc_from_fmt + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_ls_csc_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + call a%set_host() + +end subroutine psb_ls_mv_csc_from_fmt + + + +subroutine psb_ls_cp_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_cp_csc_from_fmt + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_ls_csc_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + nc = b%get_ncols() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + call a%set_host() + +end subroutine psb_ls_cp_csc_from_fmt + + +subroutine psb_ls_csc_mold(a,b,info) + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_mold + use psb_error_mod + implicit none + class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csc_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ls_csc_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_mold + +subroutine psb_ls_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_reallocate_nz + implicit none + integer(psb_ipk_), intent(in) :: nz + class(psb_ls_csc_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='ls_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ia,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,& + & a%get_ncols()+1), a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_reallocate_nz + + + +subroutine psb_ls_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_csgetblk + implicit none + + class(psb_ls_csc_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_csgetblk + +subroutine psb_ls_csc_reinit(a,clear) + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_reinit + implicit none + + class(psb_ls_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = szero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_reinit + +subroutine psb_ls_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_trim + implicit none + class(psb_ls_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, n + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + n = a%get_ncols() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_trim + +subroutine psb_ls_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csc_allocate_mnnz + +subroutine psb_ls_csc_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_s_csc_mat_mod, psb_protect_name => psb_ls_csc_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='ls_csc_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_ls_csc_print + +subroutine psb_lscscspspmm(a,b,c,info) + use psb_s_mat_mod + use psb_serial_mod, psb_protect_name => psb_lscscspspmm + + implicit none + + class(psb_ls_csc_sparse_mat), intent(in) :: a,b + type(psb_ls_csc_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_cscspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + + call csc_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csc_spspmm(a,b,c,info) + implicit none + type(psb_ls_csc_sparse_mat), intent(in) :: a,b + type(psb_ls_csc_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: icol(:), idxs(:), iaux(:) + real(psb_spk_), allocatable :: col(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + real(psb_spk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ia)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,col,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,icol,info) + if (info /= 0) return + col = dzero + icol = 0 + nzc = 1 + do j = 1,nb + c%icp(j) = nzc + nrc = 0 + do k = b%icp(j), b%icp(j+1)-1 + icl = b%ia(k) + cfb = b%val(k) + irwsz = a%icp(icl+1)-a%icp(icl) + do i = a%icp(icl),a%icp(icl+1)-1 + irw = a%ia(i) + if (icol(irw) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ia,info) + if (info /= 0) return + end if + call psb_msort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) + col(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%icp(nb+1) = nzc + + end subroutine csc_spspmm + +end subroutine psb_lscscspspmm diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index 9a5373600..8ed54ae9f 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -1018,7 +1018,6 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans) real(psb_spk_), allocatable :: tmp(:,:) logical :: tra, ctra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_csr_cssm' logical, parameter :: debug=.false. @@ -1269,8 +1268,8 @@ function psb_s_csr_maxval(a) result(res) class(psb_s_csr_sparse_mat), intent(in) :: a real(psb_spk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: info character(len=20) :: name='s_csr_maxval' logical, parameter :: debug=.false. @@ -1295,7 +1294,6 @@ function psb_s_csr_csnmi(a) result(res) real(psb_spk_) :: acc logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_csnmi' logical, parameter :: debug=.false. @@ -1304,7 +1302,7 @@ function psb_s_csr_csnmi(a) result(res) if (a%is_dev()) call a%sync() do i = 1, a%get_nrows() - acc = dzero + acc = szero do j=a%irp(i),a%irp(i+1)-1 acc = acc + abs(a%val(j)) end do @@ -1655,7 +1653,6 @@ subroutine psb_s_csr_scals(d,a,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -1704,7 +1701,6 @@ subroutine psb_s_csr_reallocate_nz(nz,a) integer(psb_ipk_), intent(in) :: nz class(psb_s_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_csr_reallocate_nz' logical, parameter :: debug=.false. @@ -1736,7 +1732,6 @@ subroutine psb_s_csr_mold(a,b,info) class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csr_mold' logical, parameter :: debug=.false. @@ -1846,7 +1841,6 @@ subroutine psb_s_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2021,7 +2015,6 @@ subroutine psb_s_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_, chksz_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2206,8 +2199,6 @@ subroutine psb_s_csr_tril(a,l,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_), allocatable :: ia(:), ja(:) - real(psb_spk_), allocatable :: val(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ @@ -2362,8 +2353,6 @@ subroutine psb_s_csr_triu(a,u,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_), allocatable :: ia(:), ja(:) - real(psb_spk_), allocatable :: val(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ @@ -2515,7 +2504,6 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_csr_csput_a' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit @@ -2527,28 +2515,24 @@ subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) debug_level = psb_get_debug_level() if (nz <= 0) then - info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_iarg_neg_; i=1 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=2 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=3 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=4 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if @@ -2652,7 +2636,7 @@ contains i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2680,7 +2664,7 @@ contains i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2720,7 +2704,7 @@ contains i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2742,7 +2726,7 @@ contains i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2776,7 +2760,6 @@ subroutine psb_s_csr_reinit(a,clear) logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -2821,7 +2804,6 @@ subroutine psb_s_csr_trim(a) implicit none class(psb_s_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz, m - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -2856,7 +2838,6 @@ subroutine psb_s_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='s_csr_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='real' @@ -3446,3 +3427,2179 @@ contains end subroutine csr_spspmm end subroutine psb_scsrspspmm + + +! +! +! ls version +! +! +subroutine psb_ls_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_get_diag + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = sone + else + do i=1, mnm + d(i) = szero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = szero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ls_csr_get_diag + + +subroutine psb_ls_csr_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_scal + use psb_string_mod + implicit none + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ls_csr_scal + + +subroutine psb_ls_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_scals + implicit none + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ls_csr_scals + + +function psb_ls_csr_maxval(a) result(res) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_maxval + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: nnz + integer(psb_ipk_) :: info + character(len=20) :: name='ls_csr_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = szero + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_ls_csr_maxval + +function psb_ls_csr_csnmi(a) result(res) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csnmi + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nr, ir, jc, nc + real(psb_spk_) :: acc + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_csnmi' + logical, parameter :: debug=.false. + + + res = szero + if (a%is_dev()) call a%sync() + + do i = 1, a%get_nrows() + acc = szero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_ls_csr_csnmi + +subroutine psb_ls_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_rowsum + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = szero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + sone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_rowsum + +subroutine psb_ls_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_arwsum + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = szero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + sone + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_arwsum + +subroutine psb_ls_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_colsum + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = szero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + sone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_colsum + +subroutine psb_ls_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_aclsum + class(psb_ls_csr_sparse_mat), intent(in) :: a + real(psb_spk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_spk_) :: acc + real(psb_spk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = szero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + sone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_aclsum + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_ls_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_reallocate_nz + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='ls_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_reallocate_nz + +subroutine psb_ls_csr_mold(a,b,info) + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_mold + use psb_error_mod + implicit none + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csr_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_ls_csr_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_ls_csr_mold + +subroutine psb_ls_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_allocate_mnnz + + +subroutine psb_ls_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csgetptn + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_ls_csr_csgetrow + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_ls_csr_tril + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end if + end do + end do + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + l%val(nzin) = val(k) + end if + end if + end do + end do + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_tril + +subroutine psb_ls_csr_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_triu + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_ls_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) + end if + end if + end do + end do + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_triu + + +subroutine psb_ls_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_csput_a + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_csr_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + + call psb_erractionsave(err_act) + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (nz <= 0) then + info = psb_err_iarg_neg_; + call psb_errpush(info,name,m_err=(/1/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/2/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/3/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/4/)) + goto 9999 + end if + + if (nz == 0) return + if (a%is_dev()) call a%sync() + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_ls_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_ls_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + real(psb_spk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,ng + integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc + character(len=20) :: name='ls_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_ls_csr_srch_upd + +end subroutine psb_ls_csr_csput_a + + +subroutine psb_ls_csr_reinit(a,clear) + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_reinit + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = szero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_reinit + +subroutine psb_ls_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_trim + implicit none + class(psb_ls_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csr_trim + +subroutine psb_ls_csr_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_csr_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_ls_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='ls_csr_print' + logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='real' + character(len=80) :: frmtv + integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_ls_csr_print + + +subroutine psb_ls_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_from_coo + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_ls_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k,ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='ls_cp_csr_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_ls_base_sparse_mat = tmp%psb_ls_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + + +end subroutine psb_ls_cp_csr_from_coo + + + +subroutine psb_ls_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_to_coo + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_ls_cp_csr_to_coo + + +subroutine psb_ls_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_to_coo + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,k,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_ls_mv_csr_to_coo + + + +subroutine psb_ls_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_from_coo + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k, ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='mv_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + +end subroutine psb_ls_mv_csr_from_coo + + +subroutine psb_ls_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_to_fmt + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_ls_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ls_mv_csr_to_fmt + + +subroutine psb_ls_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_to_fmt + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_ls_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_ls_base_sparse_mat = a%psb_ls_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_ls_cp_csr_to_fmt + + +subroutine psb_ls_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_mv_csr_from_fmt + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_ls_csr_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_ls_mv_csr_from_fmt + + + +subroutine psb_ls_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_s_base_mat_mod + use psb_realloc_mod + use psb_s_csr_mat_mod, psb_protect_name => psb_ls_cp_csr_from_fmt + implicit none + + class(psb_ls_csr_sparse_mat), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_ls_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_ls_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_ls_csr_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_ls_base_sparse_mat = b%psb_ls_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_ls_cp_csr_from_fmt + +subroutine psb_lscsrspspmm(a,b,c,info) + use psb_s_mat_mod + use psb_serial_mod, psb_protect_name => psb_lscsrspspmm + + implicit none + + class(psb_ls_csr_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_ls_csr_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: irow(:), idxs(:) + real(psb_spk_), allocatable :: row(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + real(psb_spk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + + + end subroutine csr_spspmm + +end subroutine psb_lscsrspspmm + diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index a011aabfb..64e8bbc46 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -37,8 +37,6 @@ ! for actually executing the method. ! ! -! - ! == =================================== @@ -2434,5 +2432,2423 @@ subroutine psb_s_scals(d,a,info) end subroutine psb_s_scals +subroutine psb_s_mv_from_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_mv_from_lb + implicit none + + class(psb_sspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + if (.not.allocated(a%a)) allocate(psb_s_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%mv_from_lfmt(b,info) + +end subroutine psb_s_mv_from_lb + + +subroutine psb_s_cp_from_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cp_from_lb + implicit none + + class(psb_sspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) allocate(psb_s_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%cp_from_lfmt(b,info) + +end subroutine psb_s_cp_from_lb + +subroutine psb_s_mv_to_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_mv_to_lb + implicit none + + class(psb_sspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%mv_to_lfmt(b,info) + call a%free() + end if + +end subroutine psb_s_mv_to_lb + +subroutine psb_s_cp_to_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cp_to_lb + implicit none + class(psb_sspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%cp_to_lfmt(b,info) + end if + +end subroutine psb_s_cp_to_lb + +subroutine psb_s_mv_from_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_mv_from_l + implicit none + class(psb_sspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_s_csr_sparse_mat :: a%a, stat=info) + call a%a%mv_from_lfmt(b%a,info) + else + call a%free() + end if + call b%free() + +end subroutine psb_s_mv_from_l + + +subroutine psb_s_cp_from_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cp_from_l + implicit none + + class(psb_sspmat_type), intent(out) :: a + class(psb_lsspmat_type), intent(in) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_s_csr_sparse_mat :: a%a, stat=info) + call a%a%cp_from_lfmt(b%a,info) + else + call a%free() + end if +end subroutine psb_s_cp_from_l + +subroutine psb_s_mv_to_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_mv_to_l + implicit none + + class(psb_sspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_ls_csr_sparse_mat :: b%a, stat=info) + call a%a%mv_to_lfmt(b%a,info) + else + call b%free() + end if + call a%free() + +end subroutine psb_s_mv_to_l + +subroutine psb_s_cp_to_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_s_cp_to_l + implicit none + + class(psb_sspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_ls_csr_sparse_mat :: b%a, stat=info) + call a%a%cp_to_lfmt(b%a,info) + else + call b%free() + end if + +end subroutine psb_s_cp_to_l +! +! +! ls versions +! + + +subroutine psb_ls_set_nrows(m,a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_nrows + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_nrows + + +subroutine psb_ls_set_ncols(n,a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_ncols + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_ncols + + + +! +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ +! + +subroutine psb_ls_set_dupl(n,a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_dupl + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_dupl + + +! +! Set the STATE of the internal matrix object +! + +subroutine psb_ls_set_null(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_null + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_null + + +subroutine psb_ls_set_bld(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_bld + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_bld + + +subroutine psb_ls_set_upd(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_upd + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ls_set_upd + + +subroutine psb_ls_set_asb(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_asb + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_asb + + +subroutine psb_ls_set_sorted(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_sorted + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_sorted + + +subroutine psb_ls_set_triangle(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_triangle + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_triangle + + +subroutine psb_ls_set_unit(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_unit + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_unit + + +subroutine psb_ls_set_lower(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_lower + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_lower + + +subroutine psb_ls_set_upper(a,val) + use psb_s_mat_mod, psb_protect_name => psb_ls_set_upper + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_ls_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_s_mat_mod, psb_protect_name => psb_ls_sparse_print + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,head,ivr,ivc) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_sparse_print + + +subroutine psb_ls_n_sparse_print(fname,a,iv,head,ivr,ivc) + use psb_s_mat_mod, psb_protect_name => psb_ls_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info, iout + logical :: isopen + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call a%a%print(iout,iv,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_n_sparse_print + + +subroutine psb_ls_get_neigh(a,idx,neigh,n,info,lev) + use psb_s_mat_mod, psb_protect_name => psb_ls_get_neigh + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_get_neigh + + + +subroutine psb_ls_csall(nr,nc,a,info,nz) + use psb_s_mat_mod, psb_protect_name => psb_ls_csall + use psb_s_base_mat_mod + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + call a%free() + + info = psb_success_ + allocate(psb_ls_coo_sparse_mat :: a%a, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csall + + +subroutine psb_ls_reallocate_nz(nz,a) + use psb_s_mat_mod, psb_protect_name => psb_ls_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_reallocate_nz + + +subroutine psb_ls_free(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_free + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_ls_free + + +subroutine psb_ls_trim(a) + use psb_s_mat_mod, psb_protect_name => psb_ls_trim + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_trim + + + +subroutine psb_ls_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_mat_mod, psb_protect_name => psb_ls_csput_a + use psb_s_base_mat_mod + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_a' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csput_a + +subroutine psb_ls_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_s_mat_mod, psb_protect_name => psb_ls_csput_v + use psb_s_base_mat_mod + use psb_s_vect_mod, only : psb_s_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + use psb_error_mod + implicit none + class(psb_lsspmat_type), intent(inout) :: a + type(psb_s_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csput_v + + +subroutine psb_ls_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_csgetptn + implicit none + + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csgetptn + + +subroutine psb_ls_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_csgetrow + implicit none + + class(psb_lsspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + real(psb_spk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csgetrow + + + + +subroutine psb_ls_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_csgetblk + implicit none + + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + logical :: append_ + type(psb_ls_coo_sparse_mat), allocatable :: acoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(append)) then + append_ = append + else + append_ = .false. + end if + + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then + if (allocated(b%a)) & + & call b%a%mv_to_coo(acoo,info) + end if + + if (info == psb_success_) then + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csgetblk + + +subroutine psb_ls_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_tril + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lsspmat_type), optional, intent(inout) :: u + + integer(psb_ipk_) :: err_act + character(len=20) :: name='tril' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat), allocatable :: lcoo, ucoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(lcoo,stat=info) + call l%free() + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ls_tril + +subroutine psb_ls_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_triu + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lsspmat_type), optional, intent(inout) :: l + + integer(psb_ipk_) :: err_act + character(len=20) :: name='triu' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat), allocatable :: lcoo, ucoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ucoo,stat=info) + call u%free() + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_ls_triu + + +subroutine psb_ls_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_csclip + implicit none + + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_ls_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + call b%free() + if (info == psb_success_) then + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_csclip + + +subroutine psb_ls_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_s_base_mat_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_b_csclip + implicit none + + class(psb_lsspmat_type), intent(in) :: a + type(psb_ls_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_b_csclip + + + + +subroutine psb_ls_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cscnv + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_ls_base_sparse_mat), intent(in), optional :: mold + + + class(psb_ls_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_ls_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_ls_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_ls_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(dupl)) then + call altmp%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call altmp%set_dupl(psb_dupl_def_) + end if + + if (debug) write(psb_err_unit,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%trim() + call b%asb() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cscnv + + + +subroutine psb_ls_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cscnv_ip + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_ls_base_sparse_mat), intent(in), optional :: mold + + + class(psb_ls_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_ls_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_ls_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_ls_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cscnv_ip + + + +subroutine psb_ls_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cscnv_base + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + + + type(psb_ls_coo_sparse_mat) :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == psb_success_).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_cscnv_base + + + +!!$subroutine psb_ls_clip_d(a,b,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_s_base_mat_mod +!!$ use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d +!!$ implicit none +!!$ +!!$ class(psb_lsspmat_type), intent(in) :: a +!!$ class(psb_lsspmat_type), intent(inout) :: b +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_ls_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call b%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_ls_clip_d +!!$ +!!$ +!!$ +!!$subroutine psb_ls_clip_d_ip(a,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_s_base_mat_mod +!!$ use psb_s_mat_mod, psb_protect_name => psb_ls_clip_d_ip +!!$ implicit none +!!$ +!!$ class(psb_lsspmat_type), intent(inout) :: a +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_ls_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call a%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_ls_clip_d_ip +!!$ + +subroutine psb_ls_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_mv_from + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call a%free() + allocate(a%a,mold=b, stat=info) + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_ls_mv_from + + +subroutine psb_ls_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cp_from + implicit none + class(psb_lsspmat_type), intent(out) :: a + class(psb_ls_base_sparse_mat), intent(in) :: b + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + call a%free() + ! + ! Note: it is tempting to use SOURCE allocation below; + ! however this would run the risk of messing up with data + ! allocated externally (e.g. GPU-side data). + ! + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ls_cp_from + + +subroutine psb_ls_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_mv_to + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_ls_mv_to + + +subroutine psb_ls_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cp_to + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_ls_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_ls_cp_to + +subroutine psb_ls_mold(a,b) + use psb_s_mat_mod, psb_protect_name => psb_ls_mold + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), allocatable, intent(out) :: b + integer(psb_ipk_) :: info + + allocate(b,mold=a%a, stat=info) + +end subroutine psb_ls_mold + +subroutine psb_lsspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_lsspmat_type_move + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call b%free() + call move_alloc(a%a,b%a) + + return +end subroutine psb_lsspmat_type_move + + +subroutine psb_lsspmat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_lsspmat_clone + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_lsspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lsspmat_clone + + +subroutine psb_ls_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_transp_1mat + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_transp_1mat + + + +subroutine psb_ls_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_transp_2mat + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_transp_2mat + + +subroutine psb_ls_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_transc_1mat + implicit none + class(psb_lsspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_transc_1mat + + + +subroutine psb_ls_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_transc_2mat + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_lsspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_transc_2mat + + +subroutine psb_ls_asb(a,mold) + use psb_s_mat_mod, psb_protect_name => psb_ls_asb + use psb_error_mod + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + class(psb_ls_base_sparse_mat), optional, intent(in) :: mold + class(psb_ls_base_sparse_mat), allocatable :: tmp + class(psb_ls_base_sparse_mat), pointer :: mld + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='ls_asb' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_ls_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_asb + +subroutine psb_ls_reinit(a,clear) + use psb_s_mat_mod, psb_protect_name => psb_ls_reinit + use psb_error_mod + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (a%a%has_update()) then + call a%a%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_reinit + + + + +function psb_ls_get_diag(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_get_diag + + +subroutine psb_ls_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_scal + implicit none + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info,side=side) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_scal + + +subroutine psb_ls_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_scals + implicit none + class(psb_lsspmat_type), intent(inout) :: a + real(psb_spk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ls_scals + +function psb_ls_maxval(a) result(res) + use psb_s_mat_mod, psb_protect_name => psb_ls_maxval + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%maxval() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_maxval + +function psb_ls_csnmi(a) result(res) + use psb_s_mat_mod, psb_protect_name => psb_ls_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnmi() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_csnmi + +function psb_ls_csnm1(a) result(res) + use psb_s_mat_mod, psb_protect_name => psb_ls_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnm1() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_csnm1 + + +function psb_ls_rowsum(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + call a%a%rowsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_rowsum + +function psb_ls_arwsum(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%arwsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_arwsum + +function psb_ls_colsum(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%colsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_colsum + +function psb_ls_aclsum(a,info) result(d) + use psb_s_mat_mod, psb_protect_name => psb_ls_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lsspmat_type), intent(in) :: a + real(psb_spk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%aclsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_ls_aclsum + +subroutine psb_ls_mv_from_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_mv_from_ib + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + if (.not.allocated(a%a)) allocate(psb_ls_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%mv_from_ifmt(b,info) + +end subroutine psb_ls_mv_from_ib + +subroutine psb_ls_cp_from_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cp_from_ib + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) allocate(psb_ls_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%cp_from_ifmt(b,info) + +end subroutine psb_ls_cp_from_ib + +subroutine psb_ls_mv_to_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_mv_to_ib + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%mv_to_ifmt(b,info) + call a%free() + end if + +end subroutine psb_ls_mv_to_ib + +subroutine psb_ls_cp_to_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cp_to_ib + implicit none + class(psb_lsspmat_type), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%cp_to_ifmt(b,info) + end if + +end subroutine psb_ls_cp_to_ib + +subroutine psb_ls_mv_from_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_mv_from_i + implicit none + class(psb_lsspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_ls_csr_sparse_mat :: a%a, stat=info) + call a%a%mv_from_ifmt(b%a,info) + else + call a%free() + end if + call b%free() + +end subroutine psb_ls_mv_from_i + + +subroutine psb_ls_cp_from_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cp_from_i + implicit none + + class(psb_lsspmat_type), intent(out) :: a + class(psb_sspmat_type), intent(in) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_ls_csr_sparse_mat :: a%a, stat=info) + call a%a%cp_from_ifmt(b%a,info) + else + call a%free() + end if +end subroutine psb_ls_cp_from_i + +subroutine psb_ls_mv_to_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_mv_to_i + implicit none + + class(psb_lsspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_s_csr_sparse_mat :: b%a, stat=info) + call a%a%mv_to_ifmt(b%a,info) + else + call b%free() + end if + call a%free() + +end subroutine psb_ls_mv_to_i + +subroutine psb_ls_cp_to_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_s_mat_mod, psb_protect_name => psb_ls_cp_to_i + implicit none + + class(psb_lsspmat_type), intent(in) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_s_csr_sparse_mat :: b%a, stat=info) + call a%a%cp_to_ifmt(b%a,info) + else + call b%free() + end if + +end subroutine psb_ls_cp_to_i + + + + diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index 103eeef65..ed77f84cd 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -50,8 +50,7 @@ subroutine psb_z_base_cp_to_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -75,8 +74,7 @@ subroutine psb_z_base_cp_from_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -101,8 +99,7 @@ subroutine psb_z_base_cp_to_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp @@ -144,8 +141,7 @@ subroutine psb_z_base_cp_from_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp @@ -190,8 +186,7 @@ subroutine psb_z_base_mv_to_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -228,8 +223,7 @@ subroutine psb_z_base_mv_from_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. @@ -266,8 +260,7 @@ subroutine psb_z_base_mv_to_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp @@ -297,8 +290,7 @@ subroutine psb_z_base_mv_from_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. type(psb_z_coo_sparse_mat) :: tmp @@ -344,8 +336,7 @@ subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csput' logical, parameter :: debug=.false. @@ -372,8 +363,7 @@ subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csput_v' integer :: jmin_, jmax_ logical :: append_, rscale_, cscale_ @@ -423,8 +413,7 @@ subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax, nzin logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -439,8 +428,6 @@ subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& end subroutine psb_z_base_csgetrow - - ! ! Here we have the base implementation of getblk and clip: ! this is just based on the getrow. @@ -462,10 +449,9 @@ subroutine psb_z_base_csgetblk(imin,imax,a,b,info,& integer(psb_ipk_), intent(in), optional :: iren(:) integer(psb_ipk_), intent(in), optional :: jmin,jmax logical, intent(in), optional :: rscale,cscale,chksz - integer(psb_ipk_) :: err_act, nzin, nzout - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout character(len=20) :: name='csget' - integer(psb_ipk_) :: jmin_, jmax_ + integer(psb_ipk_) :: jmin_, jmax_ logical :: append_, rscale_, cscale_ logical, parameter :: debug=.false. @@ -554,8 +540,7 @@ subroutine psb_z_base_csclip(a,b,info,& integer(psb_ipk_), intent(in), optional :: imin,imax,jmin,jmax logical, intent(in), optional :: rscale,cscale - integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb character(len=20) :: name='csget' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -649,7 +634,6 @@ subroutine psb_z_base_tril(a,l,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_dpk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -801,7 +785,6 @@ subroutine psb_z_base_triu(a,u,info,& integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz integer(psb_ipk_), allocatable :: ia(:), ja(:) complex(psb_dpk_), allocatable :: val(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ logical, parameter :: debug=.false. @@ -1000,8 +983,7 @@ subroutine psb_z_base_mold(a,b,info) class(psb_z_base_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='base_mold' logical, parameter :: debug=.false. @@ -1026,7 +1008,6 @@ subroutine psb_z_base_transp_2mat(a,b) type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='z_base_transp' call psb_erractionsave(err_act) @@ -1041,8 +1022,7 @@ subroutine psb_z_base_transp_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1)=ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1064,7 +1044,6 @@ subroutine psb_z_base_transc_2mat(a,b) type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='z_base_transc' call psb_erractionsave(err_act) @@ -1079,8 +1058,7 @@ subroutine psb_z_base_transc_2mat(a,b) info = psb_err_invalid_dynamic_type_ end select if (info /= psb_success_) then - ierr(1) = ione; - call psb_errpush(info,name,a_err=b%get_fmt(),i_err=ierr) + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) goto 9999 end if call psb_erractionrestore(err_act) @@ -1101,7 +1079,6 @@ subroutine psb_z_base_transp_1mat(a) type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='z_base_transp' call psb_erractionsave(err_act) @@ -1133,7 +1110,6 @@ subroutine psb_z_base_transc_1mat(a) type(psb_z_coo_sparse_mat) :: tmp integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=*), parameter :: name='z_base_transc' call psb_erractionsave(err_act) @@ -1182,8 +1158,7 @@ subroutine psb_z_base_csmm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_csmm' logical, parameter :: debug=.false. @@ -1209,8 +1184,7 @@ subroutine psb_z_base_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_csmv' logical, parameter :: debug=.false. @@ -1237,8 +1211,7 @@ subroutine psb_z_base_inner_cssm(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_inner_cssm' logical, parameter :: debug=.false. @@ -1264,8 +1237,7 @@ subroutine psb_z_base_inner_cssv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_inner_cssv' logical, parameter :: debug=.false. @@ -1296,7 +1268,6 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_dpk_), allocatable :: tmp(:,:) integer(psb_ipk_) :: err_act, nar,nac,nc, i character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_cssm' logical, parameter :: debug=.false. @@ -1313,14 +1284,12 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) nc = min(size(x,2), size(y,2)) if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1340,8 +1309,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1364,8 +1332,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1389,8 +1356,7 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1404,16 +1370,13 @@ subroutine psb_z_base_cssm(alpha,a,x,beta,y,info,trans,scale,d) goto 9999 end if - call psb_erractionrestore(err_act) return - 9999 call psb_error_handler(err_act) return - end subroutine psb_z_base_cssm @@ -1430,9 +1393,8 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_dpk_), intent(in), optional :: d(:) complex(psb_dpk_), allocatable :: tmp(:) - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='z_cssm' logical, parameter :: debug=.false. @@ -1449,14 +1411,12 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (size(x,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (size(y,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1476,8 +1436,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (size(d,1) < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if @@ -1495,8 +1454,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (size(d,1) < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1520,8 +1478,7 @@ subroutine psb_z_base_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -1580,8 +1537,7 @@ subroutine psb_z_base_scals(d,a,info) complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_scals' logical, parameter :: debug=.false. @@ -1607,8 +1563,7 @@ subroutine psb_z_base_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_scal' logical, parameter :: debug=.false. @@ -1623,8 +1578,6 @@ subroutine psb_z_base_scal(d,a,info,side) end subroutine psb_z_base_scal - - function psb_z_base_maxval(a) result(res) use psb_error_mod use psb_const_mod @@ -1634,8 +1587,7 @@ function psb_z_base_maxval(a) result(res) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='maxval' logical, parameter :: debug=.false. @@ -1662,8 +1614,7 @@ function psb_z_base_csnmi(a) result(res) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnmi' real(psb_dpk_), allocatable :: vt(:) @@ -1701,8 +1652,7 @@ function psb_z_base_csnm1(a) result(res) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='csnm1' real(psb_dpk_), allocatable :: vt(:) @@ -1737,8 +1687,7 @@ subroutine psb_z_base_rowsum(d,a) class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1760,8 +1709,7 @@ subroutine psb_z_base_arwsum(d,a) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='arwsum' logical, parameter :: debug=.false. @@ -1783,8 +1731,7 @@ subroutine psb_z_base_colsum(d,a) class(psb_z_base_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1806,8 +1753,7 @@ subroutine psb_z_base_aclsum(d,a) class(psb_z_base_sparse_mat), intent(in) :: a real(psb_dpk_), intent(out) :: d(:) - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1822,7 +1768,6 @@ subroutine psb_z_base_aclsum(d,a) end subroutine psb_z_base_aclsum - subroutine psb_z_base_get_diag(a,d,info) use psb_error_mod use psb_const_mod @@ -1833,8 +1778,7 @@ subroutine psb_z_base_get_diag(a,d,info) complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -1900,9 +1844,8 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) complex(psb_dpk_), allocatable :: tmp(:) class(psb_z_base_vect_type), allocatable :: tmpv - integer(psb_ipk_) :: err_act, nar,nac,nc, i - character(len=1) :: scale_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nar,nac,nc, i + character(len=1) :: scale_ character(len=20) :: name='z_cssm' logical, parameter :: debug=.false. @@ -1919,14 +1862,12 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) nc = 1 if (x%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,nac/)) goto 9999 end if if (y%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,nar/)) goto 9999 end if @@ -1949,8 +1890,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) if (psb_toupper(scale_) == 'R') then if (d%get_nrows() < nac) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nac; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nac/)) goto 9999 end if allocate(tmpv, mold=y,stat=info) @@ -1968,8 +1908,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else if (psb_toupper(scale_) == 'L') then if (d%get_nrows() < nar) then info = psb_err_input_asize_small_i_ - ierr(1) = 9; ierr(2) = nar; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/9_psb_ipk_,nar/)) goto 9999 end if @@ -1995,8 +1934,7 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d) else info = 31 - ierr(1) = 8; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr,a_err=scale_) + call psb_errpush(info,name,i_err=(/8_psb_ipk_,izero/),a_err=scale_) goto 9999 end if else @@ -2034,8 +1972,7 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_inner_vect_sv' logical, parameter :: debug=.false. @@ -2059,3 +1996,2039 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans) return end subroutine psb_z_base_inner_vect_sv + + +subroutine psb_z_base_cp_to_lcoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_cp_to_lcoo + +subroutine psb_z_base_cp_from_lcoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_lcoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_cp_from_lcoo + +subroutine psb_z_base_cp_to_lfmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: icoo + type(psb_lz_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%cp_to_lcoo(b,info) + class default + call a%cp_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call b%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_cp_to_lfmt + +subroutine psb_z_base_cp_from_lfmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_cp_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: icoo + type(psb_lz_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%cp_from_lcoo(b,info) + class default + call b%cp_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call a%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_cp_from_lfmt + + +subroutine psb_z_base_mv_to_lcoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lcoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_mv_to_lcoo + +subroutine psb_z_base_mv_from_lcoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_lcoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lcoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_lcoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_mv_from_lcoo + + +subroutine psb_z_base_mv_to_lfmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_to_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_lfmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: icoo + type(psb_lz_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%mv_to_lcoo(b,info) + class default + call a%mv_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call b%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_mv_to_lfmt + +subroutine psb_z_base_mv_from_lfmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mv_from_lfmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_lfmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: icoo + type(psb_lz_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%mv_from_lcoo(b,info) + class default + call b%mv_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call a%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_base_mv_from_lfmt + +! +! +! lz implementation +! +! +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + +subroutine psb_lz_base_cp_to_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_cp_to_coo + +subroutine psb_lz_base_cp_from_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_cp_from_coo + + +subroutine psb_lz_base_cp_to_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_to_fmt + +subroutine psb_lz_base_cp_from_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_from_fmt + + +subroutine psb_lz_base_mv_to_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_to_coo + +subroutine psb_lz_base_mv_from_coo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_coo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_coo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_from_coo + + +subroutine psb_lz_base_mv_to_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_fmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + + return + +end subroutine psb_lz_base_mv_to_fmt + +subroutine psb_lz_base_mv_from_fmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_fmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_fmt' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + select type(b) + type is (psb_lz_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + return + +end subroutine psb_lz_base_mv_from_fmt + +subroutine psb_lz_base_clean_zeros(a, info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_clean_zeros + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + ! + type(psb_lz_coo_sparse_mat) :: tmpcoo + + call a%mv_to_coo(tmpcoo,info) + if (info == 0) call tmpcoo%clean_zeros(info) + if (info == 0) call a%mv_from_coo(tmpcoo,info) + +end subroutine psb_lz_base_clean_zeros + + +subroutine psb_lz_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_a + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_csput_a + +subroutine psb_lz_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csput_v + use psb_z_base_vect_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_vect_type), intent(inout) :: val + class(psb_l_base_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + integer :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + if (a%is_dev()) call a%sync() + if (val%is_dev()) call val%sync() + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + call a%csput_a(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_csput_v + +subroutine psb_lz_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csgetrow + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_csgetrow + + + +! +! Here we have the base implementation of getblk and clip: +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_lz_base_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csgetblk + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout + character(len=20) :: name='csget' + integer(psb_lpk_) :: jmin_, jmax_ + logical :: append_, rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + if (present(rscale)) then + rscale_=rscale + else + rscale_=.false. + end if + if (present(cscale)) then + cscale_=cscale + else + cscale_=.false. + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if (append_.and.(rscale_.or.cscale_)) then + write(psb_err_unit,*) & + & 'lz_csgetblk: WARNING: dubious input: append_ and rscale_|cscale_' + end if + + if (rscale_) then + call b%set_nrows(imax-imin+1) + else + call b%set_nrows(max(min(imax,a%get_nrows()),b%get_nrows())) + end if + + if (cscale_) then + call b%set_ncols(jmax_-jmin_+1) + else + call b%set_ncols(max(min(jmax_,a%get_ncols()),b%get_ncols())) + end if + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_csgetblk + + +subroutine psb_lz_base_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csclip + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_lpk_) :: nzin, nzout, imin_, imax_, jmin_, jmax_, mb,nb + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + nzin = 0 + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = a%get_nrows() ! Should this be imax_ ?? + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = a%get_ncols() ! Should this be jmax_ ?? + endif + call b%allocate(mb,nb) + call a%csget(imin_,imax_,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin_, jmax=jmax_, append=.false., & + & nzin=nzin, rscale=rscale_, cscale=cscale_) + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_csclip + + +! +! Here we have the base implementation of tril and triu +! this is just based on the getrow. +! If performance is critical it can be overridden. +! +subroutine psb_lz_base_tril(a,l,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,u) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_tril + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + complex(psb_dpk_), allocatable :: val(:) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + integer(psb_lpk_), parameter :: nbk=8 + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_, nbk + ibk = min(nbk,imax_-i+1) + call a%csget(i,i+ibk-1,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + if ((ja(k)-ia(k))<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = ia(k) + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = ia(k) + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end do + end do + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >= -1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + do i=imin_,imax_ + k = min(jmax_,i+diag_) + call a%csget(i,i,nzout,l%ia,l%ja,l%val,info,& + & jmin=jmin_, jmax=k, append=.true., & + & nzin=nzin) + if (info /= psb_success_) goto 9999 + call l%set_nzeros(nzin+nzout) + nzin = nzin+nzout + end do + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_tril + +subroutine psb_lz_base_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_triu + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k, ibk + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_lpk_), allocatable :: ia(:), ja(:) + complex(psb_dpk_), allocatable :: val(:) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + integer(psb_lpk_), parameter :: nbk=8 + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + call psb_realloc(max(mb,nb),ia,info) + call psb_realloc(max(mb,nb),ja,info) + call psb_realloc(max(mb,nb),val,info) + do i=imin_,imax_, nbk + ibk = min(nbk,imax_-i+1) + call a%csget(i,i+ibk-1,nzout,ia,ja,val,info,& + & jmin=jmin_, jmax=jmax_) + do k=1, nzout + if ((ja(k)-ia(k))= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_triu + + + +subroutine psb_lz_base_clone(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_clone + use psb_error_mod + implicit none + + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), allocatable, intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b, stat=info) + end if + if (info /= 0) then + info = psb_err_alloc_dealloc_ + return + end if + + ! Do not use SOURCE allocation: this makes sure that + ! memory allocated elsewhere is treated properly. + allocate(b,mold=a,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call b%cp_from_fmt(a, info) + +end subroutine psb_lz_base_clone + +subroutine psb_lz_base_make_nonunit(a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_make_nonunit + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + type(psb_lz_coo_sparse_mat) :: tmp + + integer(psb_ipk_) :: info + integer(psb_lpk_) :: i, j, m, n, nz, mnm + + if (a%is_unit()) then + call a%mv_to_coo(tmp,info) + if (info /= 0) return + m = tmp%get_nrows() + n = tmp%get_ncols() + mnm = min(m,n) + nz = tmp%get_nzeros() + call tmp%reallocate(nz+mnm) + do i=1, mnm + tmp%val(nz+i) = zone + tmp%ia(nz+i) = i + tmp%ja(nz+i) = i + end do + call tmp%set_nzeros(nz+mnm) + call tmp%set_unit(.false.) + call tmp%fix(info) + if (info /= 0) & + & call a%mv_from_coo(tmp,info) + end if + +end subroutine psb_lz_base_make_nonunit + +subroutine psb_lz_base_mold(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mold + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='base_mold' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_mold + +subroutine psb_lz_base_transp_2mat(a,b) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transp_2mat + use psb_error_mod + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lz_base_transp' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_lz_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_transp_2mat + +subroutine psb_lz_base_transc_2mat(a,b) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transc_2mat + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_lbase_sparse_mat), intent(out) :: b + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lz_base_transc' + + call psb_erractionsave(err_act) + + info = psb_success_ + select type(b) + class is (psb_lz_base_sparse_mat) + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call b%mv_from_coo(tmp,info) + class default + info = psb_err_invalid_dynamic_type_ + end select + if (info /= psb_success_) then + call psb_errpush(info,name,a_err=b%get_fmt(),i_err=(/ione/)) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lz_base_transc_2mat + +subroutine psb_lz_base_transp_1mat(a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transp_1mat + use psb_error_mod + implicit none + + class(psb_lz_base_sparse_mat), intent(inout) :: a + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lz_base_transp' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transp() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_transp_1mat + +subroutine psb_lz_base_transc_1mat(a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_transc_1mat + implicit none + + class(psb_lz_base_sparse_mat), intent(inout) :: a + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act, info + character(len=*), parameter :: name='lz_base_transc' + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call tmp%transc() + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_transc_1mat + +subroutine psb_lz_base_scals(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scals + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_scals' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_scals + +subroutine psb_lz_base_scal(d,a,info,side) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_scal + use psb_error_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_scal' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_scal + +function psb_lz_base_maxval(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_maxval + + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + res = dzero + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end function psb_lz_base_maxval + +function psb_lz_base_csnmi(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csnmi + + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + real(psb_dpk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = dzero + call psb_realloc(a%get_nrows(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%arwsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_base_csnmi + +function psb_lz_base_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_csnm1 + + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + real(psb_dpk_), allocatable :: vt(:) + + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + res = dzero + call psb_realloc(a%get_ncols(),vt,info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%aclsum(vt) + res = maxval(vt) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_base_csnm1 + +subroutine psb_lz_base_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_rowsum + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_rowsum + +subroutine psb_lz_base_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_arwsum + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_arwsum + +subroutine psb_lz_base_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_colsum + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_colsum + +subroutine psb_lz_base_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_aclsum + class(psb_lz_base_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_aclsum + +subroutine psb_lz_base_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_get_diag + + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = psb_err_missing_override_method_ + call psb_errpush(info,name,a_err=a%get_fmt()) + + call psb_error_handler(err_act) + +end subroutine psb_lz_base_get_diag + + + +subroutine psb_lz_base_cp_to_icoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call tmp%mv_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_to_icoo + +subroutine psb_lz_base_cp_from_icoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat) :: tmp + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + call tmp%cp_from_icoo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_from_icoo + + +subroutine psb_lz_base_cp_to_ifmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: icoo + type(psb_lz_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_z_coo_sparse_mat) + call a%cp_to_icoo(b,info) + class default + call a%cp_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call b%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_to_ifmt + +subroutine psb_lz_base_cp_from_ifmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_cp_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: icoo + type(psb_lz_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_z_coo_sparse_mat) + call a%cp_from_icoo(b,info) + class default + call b%cp_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call a%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_cp_from_ifmt + + +subroutine psb_lz_base_mv_to_icoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_icoo' + logical, parameter :: debug=.false. + + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_to_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to coo') + goto 9999 + end if + + call a%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_to_icoo + +subroutine psb_lz_base_mv_from_icoo(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_icoo + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_icoo' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + call a%cp_from_icoo(b,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='from coo') + goto 9999 + end if + + call b%free() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_from_icoo + + +subroutine psb_lz_base_mv_to_ifmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_to_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_ifmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: icoo + type(psb_lz_coo_sparse_mat) :: lcoo + + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_z_coo_sparse_mat) + call a%mv_to_icoo(b,info) + class default + call a%mv_to_coo(lcoo,info) + if (info == psb_success_) call lcoo%mv_to_icoo(icoo,info) + if (info == psb_success_) call b%mv_from_coo(icoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_to_ifmt + +subroutine psb_lz_base_mv_from_ifmt(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_base_mv_from_ifmt + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_lz_base_sparse_mat), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_ifmt' + logical, parameter :: debug=.false. + type(psb_z_coo_sparse_mat) :: icoo + type(psb_lz_coo_sparse_mat) :: lcoo + ! + ! Default implementation + ! + info = psb_success_ + call psb_erractionsave(err_act) + + select type(b) + type is (psb_z_coo_sparse_mat) + call a%mv_from_icoo(b,info) + class default + call b%mv_to_coo(icoo,info) + if (info == psb_success_) call icoo%mv_to_lcoo(lcoo,info) + if (info == psb_success_) call a%mv_from_coo(lcoo,info) + end select + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name, a_err='to/from coo') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_base_mv_from_ifmt + + diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index e1883e03a..db42931cd 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -29,7 +29,6 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! - subroutine psb_z_coo_get_diag(a,d,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_get_diag use psb_error_mod @@ -39,8 +38,7 @@ subroutine psb_z_coo_get_diag(a,d,info) complex(psb_dpk_), intent(out) :: d(:) integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j character(len=20) :: name='get_diag' logical, parameter :: debug=.false. @@ -51,8 +49,7 @@ subroutine psb_z_coo_get_diag(a,d,info) mnm = min(a%get_nrows(),a%get_ncols()) if (size(d) < mnm) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -88,8 +85,7 @@ subroutine psb_z_coo_scal(d,a,info,side) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: side - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' character :: side_ logical :: left @@ -114,8 +110,7 @@ subroutine psb_z_coo_scal(d,a,info,side) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -127,8 +122,7 @@ subroutine psb_z_coo_scal(d,a,info,side) m = a%get_ncols() if (size(d) < m) then info=psb_err_input_asize_invalid_i_ - ierr(1) = 2; ierr(2) = size(d); - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,size(d,kind=psb_ipk_)/)) goto 9999 end if @@ -158,8 +152,7 @@ subroutine psb_z_coo_scals(d,a,info) complex(psb_dpk_), intent(in) :: d integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act,mnm, i, j, m character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -193,15 +186,16 @@ subroutine psb_z_coo_reallocate_nz(nz,a) implicit none integer(psb_ipk_), intent(in) :: nz class(psb_z_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='z_coo_reallocate_nz' logical, parameter :: debug=.false. call psb_erractionsave(err_act) nz_ = max(nz,ione) - call psb_realloc(nz_,a%ia,a%ja,a%val,info) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) if (info /= psb_success_) then call psb_errpush(psb_err_alloc_dealloc_,name) @@ -224,8 +218,7 @@ subroutine psb_z_coo_mold(a,b,info) class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. @@ -259,8 +252,7 @@ subroutine psb_z_coo_reinit(a,clear) class(psb_z_coo_sparse_mat), intent(inout) :: a logical, intent(in), optional :: clear - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -306,8 +298,7 @@ subroutine psb_z_coo_trim(a) use psb_error_mod implicit none class(psb_z_coo_sparse_mat), intent(inout) :: a - integer(psb_ipk_) :: err_act, info, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -363,8 +354,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) integer(psb_ipk_), intent(in) :: m,n class(psb_z_coo_sparse_mat), intent(inout) :: a integer(psb_ipk_), intent(in), optional :: nz - integer(psb_ipk_) :: err_act, info, nz_ - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info, nz_ character(len=20) :: name='allocate_mnz' logical, parameter :: debug=.false. @@ -372,14 +362,12 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) info = psb_success_ if (m < 0) then info = psb_err_iarg_neg_ - ierr(1) = ione; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/ione,izero/)) goto 9999 endif if (n < 0) then info = psb_err_iarg_neg_ - ierr(1) = 2; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) goto 9999 endif if (present(nz)) then @@ -389,8 +377,7 @@ subroutine psb_z_coo_allocate_mnnz(m,n,a,nz) end if if (nz_ < 0) then info = psb_err_iarg_neg_ - ierr(1) = 3; ierr(2) = izero; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) goto 9999 endif if (info == psb_success_) call psb_realloc(nz_,a%ia,info) @@ -431,13 +418,12 @@ subroutine psb_z_coo_print(iout,a,iv,head,ivr,ivc) character(len=*), optional :: head integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='complex' - character(len=80) :: frmtv + character(len=80) :: frmtv integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' @@ -507,7 +493,7 @@ function psb_z_coo_get_nz_row(idx,a) result(res) nza = a%get_nzeros() if (a%is_by_rows()) then ! In this case we can do a binary search. - ip = psb_ibsrch(idx,nza,a%ia) + ip = psb_bsrch(idx,nza,a%ia) if (ip /= -1) return jp = ip do @@ -560,8 +546,7 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) complex(psb_dpk_) :: acc complex(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_csmm' logical, parameter :: debug=.false. @@ -591,14 +576,12 @@ subroutine psb_z_coo_cssm(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -916,8 +899,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) complex(psb_dpk_) :: acc complex(psb_dpk_), allocatable :: tmp(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_cssv_impl' logical, parameter :: debug=.false. @@ -941,14 +923,12 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans) m = a%get_nrows() if (size(x,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),m/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if if (.not. (a%is_triangle())) then @@ -1260,8 +1240,7 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc complex(psb_dpk_) :: acc logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_csmv_impl' logical, parameter :: debug=.false. @@ -1295,16 +1274,15 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if + nnz = a%get_nzeros() if (alpha == zzero) then @@ -1448,15 +1426,14 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) class(psb_z_coo_sparse_mat), intent(in) :: a complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:) complex(psb_dpk_), intent(inout) :: y(:,:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info character, optional, intent(in) :: trans character :: trans_ integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc complex(psb_dpk_), allocatable :: acc(:) logical :: tra, ctra - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_csmm_impl' logical, parameter :: debug=.false. @@ -1492,14 +1469,12 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans) end if if (size(x,1) < n) then info = psb_err_input_asize_small_i_ - ierr(1) = 3; ierr(2) = size(x,1); ierr(3) = n; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_,size(x,1,kind=psb_ipk_),n/)) goto 9999 end if if (size(y,1) < m) then info = psb_err_input_asize_small_i_ - ierr(1) = 5; ierr(2) = size(y,1); ierr(3) =m; - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,size(y,1,kind=psb_ipk_),m/)) goto 9999 end if @@ -1652,8 +1627,7 @@ function psb_z_coo_maxval(a) result(res) class(psb_z_coo_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info character(len=20) :: name='z_coo_maxval' logical, parameter :: debug=.false. @@ -1684,7 +1658,6 @@ function psb_z_coo_csnmi(a) result(res) real(psb_dpk_), allocatable :: vt(:) logical :: tra, is_unit integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_coo_csnmi' logical, parameter :: debug=.false. @@ -1746,7 +1719,6 @@ function psb_z_coo_csnm1(a) result(res) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_coo_csnm1' logical, parameter :: debug=.false. @@ -1785,7 +1757,6 @@ subroutine psb_z_coo_rowsum(d,a) complex(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1793,10 +1764,10 @@ subroutine psb_z_coo_rowsum(d,a) if (a%is_dev()) call a%sync() m = a%get_nrows() + if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1834,7 +1805,6 @@ subroutine psb_z_coo_arwsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='rowsum' logical, parameter :: debug=.false. @@ -1844,8 +1814,7 @@ subroutine psb_z_coo_arwsum(d,a) m = a%get_nrows() if (size(d) < m) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = m - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),m/)) goto 9999 end if @@ -1882,7 +1851,6 @@ subroutine psb_z_coo_colsum(d,a) complex(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='colsum' logical, parameter :: debug=.false. @@ -1892,8 +1860,7 @@ subroutine psb_z_coo_colsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if @@ -1931,7 +1898,6 @@ subroutine psb_z_coo_aclsum(d,a) real(psb_dpk_), allocatable :: vt(:) logical :: tra integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='aclsum' logical, parameter :: debug=.false. @@ -1941,11 +1907,11 @@ subroutine psb_z_coo_aclsum(d,a) n = a%get_ncols() if (size(d) < n) then info=psb_err_input_asize_small_i_ - ierr(1) = 1; ierr(2) = size(d); ierr(3) = n - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_,size(d,kind=psb_ipk_),n/)) goto 9999 end if + if (a%is_unit()) then d = done else @@ -1969,7 +1935,6 @@ subroutine psb_z_coo_aclsum(d,a) end subroutine psb_z_coo_aclsum - ! == ================================== ! ! @@ -2004,8 +1969,7 @@ subroutine psb_z_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& logical, intent(in), optional :: rscale,cscale logical :: append_, rscale_, cscale_ - integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2121,7 +2085,7 @@ contains if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do - ip = psb_ibsrch(irw,nza,a%ia) + ip = psb_bsrch(irw,nza,a%ia) if (ip /= -1) exit irw = irw + 1 if (irw > imax) then @@ -2146,7 +2110,7 @@ contains end if do - jp = psb_ibsrch(lrw,nza,a%ia) + jp = psb_bsrch(lrw,nza,a%ia) if (jp /= -1) exit lrw = lrw - 1 if (irw > lrw) then @@ -2280,7 +2244,6 @@ subroutine psb_z_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_, chksz_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2404,7 +2367,7 @@ contains if (debug_level >= psb_debug_serial_)& & write(debug_unit,*) trim(name), ': srtdcoo ' do - ip = psb_ibsrch(irw,nza,a%ia) + ip = psb_bsrch(irw,nza,a%ia) if (ip /= -1) exit irw = irw + 1 if (irw > imax) then @@ -2429,7 +2392,7 @@ contains end if do - jp = psb_ibsrch(lrw,nza,a%ia) + jp = psb_bsrch(lrw,nza,a%ia) if (jp /= -1) exit lrw = lrw - 1 if (irw > lrw) then @@ -2566,12 +2529,11 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_), intent(in), optional :: gtl(:) - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='z_coo_csput_a_impl' logical, parameter :: debug=.false. - integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit - + integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit + info = psb_success_ debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -2580,27 +2542,23 @@ subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (nz < 0) then info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) goto 9999 end if if (size(ia) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) goto 9999 end if if (size(ja) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) goto 9999 end if if (size(val) < nz) then info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) goto 9999 end if @@ -2760,7 +2718,7 @@ contains if ((ir > 0).and.(ir <= nr)) then ic = gtl(ic) if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2778,7 +2736,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2802,7 +2760,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2820,7 +2778,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2853,7 +2811,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2871,7 +2829,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2890,7 +2848,7 @@ contains if ((ir > 0).and.(ir <= nr)) then if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia) + i1 = psb_bsrch(ir,nnz,a%ia) i2 = i1 do if (i2+1 > nnz) exit @@ -2908,7 +2866,7 @@ contains i2 = 1 end if nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ja(i1:i2)) + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2941,8 +2899,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act, nz - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, nz character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -2984,8 +2941,7 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3031,8 +2987,7 @@ subroutine psb_z_cp_coo_to_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3064,8 +3019,7 @@ subroutine psb_z_cp_coo_from_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(in) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3099,8 +3053,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3142,8 +3095,7 @@ subroutine psb_z_mv_coo_from_coo(a,b,info) class(psb_z_coo_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3187,8 +3139,7 @@ subroutine psb_z_mv_coo_to_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='to_coo' logical, parameter :: debug=.false. @@ -3220,8 +3171,7 @@ subroutine psb_z_mv_coo_from_fmt(a,b,info) class(psb_z_base_sparse_mat), intent(inout) :: b integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act character(len=20) :: name='from_coo' logical, parameter :: debug=.false. integer(psb_ipk_) :: m,n,nz @@ -3255,8 +3205,7 @@ subroutine psb_z_coo_cp_from(a,b) type(psb_z_coo_sparse_mat), intent(in) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='cp_from' logical, parameter :: debug=.false. @@ -3286,8 +3235,7 @@ subroutine psb_z_coo_mv_from(a,b) type(psb_z_coo_sparse_mat), intent(inout) :: b - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: err_act, info character(len=20) :: name='mv_from' logical, parameter :: debug=.false. @@ -3324,7 +3272,6 @@ subroutine psb_z_fix_coo(a,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_, nra, nca integer(psb_ipk_) :: i,j, irw, icl, err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' info = psb_success_ @@ -3375,6 +3322,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) use psb_z_base_mat_mod, psb_protect_name => psb_z_fix_coo_inner use psb_string_mod use psb_ip_reord_mod + use psb_sort_mod implicit none integer(psb_ipk_), intent(in) :: nr, nc, nzin, dupl @@ -3388,7 +3336,6 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) integer(psb_ipk_) :: nza, nzl,iret,idir_, dupl_ integer(psb_ipk_) :: i,j, irw, icl, err_act, ip,is, imx, k, ii integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: ierr(5) character(len=20) :: name = 'psb_fixcoo' logical :: srt_inp, use_buffers @@ -3461,7 +3408,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ja(i:imx),ix2,iret) + call psi_msort_up(nzl,ja(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3572,7 +3519,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,jas(i:imx),ix2,iret) + call psi_msort_up(nzl,jas(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3665,7 +3612,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) ! If we did not have enough memory for buffers, ! let's try in place. ! - call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret) + call psi_msort_up(nzin,ia(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3677,7 +3624,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret) + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -3784,7 +3731,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ia(i:imx),ix2,iret) + call psi_msort_up(nzl,ia(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:imx),& & ia(i:imx),ja(i:imx),ix2) @@ -3893,7 +3840,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) imx = i+nzl-1 if (nzl > 0) then - call psi_i_msort_up(nzl,ias(i:imx),ix2,iret) + call psi_msort_up(nzl,ias(i:imx),ix2,iret) if (iret == 0) & & call psb_ip_reord(nzl,vs(i:imx),& & ias(i:imx),jas(i:imx),ix2) @@ -3980,7 +3927,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) else if (.not.use_buffers) then - call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret) + call psi_msort_up(nzin,ja(1:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzin,val,ia,ja,iaux) i = 1 @@ -3991,7 +3938,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) if (j > nzin) exit enddo nzl = j - i - call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret) + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) if (iret == 0) & & call psb_ip_reord(nzl,val(i:i+nzl-1),& & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) @@ -4082,3 +4029,3102 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) end subroutine psb_z_fix_coo_inner + +subroutine psb_z_cp_coo_to_lcoo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_to_lcoo + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lbase_sparse_mat = a%psb_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_z_cp_coo_to_lcoo + +subroutine psb_z_cp_coo_from_lcoo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_z_cp_coo_from_lcoo + implicit none + class(psb_z_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_ipk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_base_sparse_mat = b%psb_lbase_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_z_cp_coo_from_lcoo + + +! +! +! lz coo impl +! +! + +subroutine psb_lz_coo_get_diag(a,d,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + if (a%is_unit()) then + d(1:mnm) = zone + else + d(1:mnm) = zzero + do i=1,a%get_nzeros() + j=a%ia(i) + if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then + d(j) = a%val(i) + endif + enddo + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_get_diag + +subroutine psb_lz_coo_scal(d,a,info,side) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scal + use psb_error_mod + use psb_const_mod + use psb_string_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,l_err=(/2_psb_lpk_,size(d,kind=psb_lpk_)/)) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_scal + + +subroutine psb_lz_coo_scals(d,a,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_scals + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_scals + + +function psb_lz_coo_maxval(a) result(res) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_maxval + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + character(len=20) :: name='z_coo_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + res = done + else + res = dzero + end if + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if + +end function psb_lz_coo_maxval + +function psb_lz_coo_csnmi(a) result(res) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnmi + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_coo_csnmi' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + is_unit = a%is_unit() + if (a%is_by_rows()) then + i = 1 + j = i + res = dzero + do while (i<=nnz) + do while ((a%ia(j) == a%ia(i)).and. (j <= nnz)) + j = j+1 + enddo + if (is_unit) then + acc = done + else + acc = dzero + end if + do k=i, j-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + i = j + end do + else + m = a%get_nrows() + allocate(vt(m),stat=info) + if (info /= 0) return + if (is_unit) then + vt = done + else + vt = dzero + end if + do j=1, nnz + i = a%ia(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:m)) + deallocate(vt,stat=info) + end if + +end function psb_lz_coo_csnmi + + +function psb_lz_coo_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csnm1 + + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_coo_csnm1' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + n = a%get_ncols() + allocate(vt(n),stat=info) + if (info /= 0) return + if (a%is_unit()) then + vt = done + else + vt = dzero + end if + do j=1, nnz + i = a%ja(j) + vt(i) = vt(i) + abs(a%val(j)) + end do + res = maxval(vt(1:n)) + deallocate(vt,stat=info) + + return + +end function psb_lz_coo_csnm1 + +subroutine psb_lz_coo_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_rowsum + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = zone + else + d = zzero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + a%val(j) + end do + + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_rowsum + +subroutine psb_lz_coo_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_arwsum + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,n, nnz, ir, jc, nc + integer(psb_epk_) :: m + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),m/)) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + nnz = a%get_nzeros() + do j=1, nnz + i = a%ia(j) + d(i) = d(i) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_arwsum + +subroutine psb_lz_coo_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_colsum + class(psb_lz_coo_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + if (a%is_unit()) then + d = zone + else + d = zzero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + a%val(j) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_colsum + +subroutine psb_lz_coo_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_aclsum + class(psb_lz_coo_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m, nnz, ir, jc, nc + integer(psb_epk_) :: n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + call psb_errpush(info,name,e_err=(/1_psb_epk_,size(d,kind=psb_epk_),n/)) + goto 9999 + end if + + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + nnz = a%get_nzeros() + do j=1, nnz + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_aclsum + +subroutine psb_lz_coo_reallocate_nz(nz,a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reallocate_nz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='lz_coo_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + nz_ = max(nz,ione) + call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_reallocate_nz + +subroutine psb_lz_coo_mold(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_mold + use psb_error_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='coo_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lz_coo_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_mold + +subroutine psb_lz_coo_reinit(a,clear) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_reinit + use psb_error_mod + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_dev()) call a%sync() + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_host() + call a%set_upd() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_reinit + + + +subroutine psb_lz_coo_trim(a) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_trim + use psb_realloc_mod + use psb_error_mod + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_trim + +subroutine psb_lz_coo_clean_zeros(a, info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_clean_zeros + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: info + ! + integer(psb_lpk_) :: i,j,k, nzin + + info = 0 + nzin = a%get_nzeros() + j = 0 + do i=1, nzin + if (a%val(i) /= zzero) then + j = j + 1 + a%val(j) = a%val(i) + a%ia(j) = a%ia(i) + a%ja(j) = a%ja(i) + end if + end do + call a%set_nzeros(j) + call a%trim() +end subroutine psb_lz_coo_clean_zeros + + + +subroutine psb_lz_coo_allocate_mnnz(m,n,a,nz) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_allocate_mnnz + use psb_error_mod + use psb_realloc_mod + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_ipk_) :: err_act, info + integer(psb_lpk_) :: nz_ + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,izero/)) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_,izero/)) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_,izero/)) + goto 9999 + endif + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_nzeros(lzero) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + ! An empty matrix is sorted! + call a%set_sorted(.true.) + call a%set_host() + end if + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_allocate_mnnz + + + +subroutine psb_lz_coo_print(iout,a,iv,head,ivr,ivc) + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_print + use psb_string_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_coo_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_lpk_) :: i,j, nmx, ni, nr, nc, nz + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do j=1,a%get_nzeros() + write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j) + enddo + else + if (present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j) + enddo + else if (present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j) + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do j=1,a%get_nzeros() + write(iout,frmtv) a%ia(j),a%ja(j),a%val(j) + enddo + endif + endif + +end subroutine psb_lz_coo_print + + + + +function psb_lz_coo_get_nz_row(idx,a) result(res) + use psb_const_mod + use psb_sort_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_get_nz_row + implicit none + + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_) :: res + integer(psb_lpk_) :: nzin_, nza,ip,jp,i,k + integer(psb_ipk_) :: inza + + if (a%is_dev()) call a%sync() + res = 0 + nza = a%get_nzeros() + if (a%is_by_rows()) then + ! In this case we can do a binary search. + inza = nza + ip = psb_bsrch(idx,inza,a%ia) + if (ip /= -1) return + jp = ip + do + if (ip < 2) exit + if (a%ia(ip-1) == idx) then + ip = ip -1 + else + exit + end if + end do + do + if (jp == nza) exit + if (a%ia(jp+1) == idx) then + jp = jp + 1 + else + exit + end if + end do + + res = jp - ip +1 + + else + + res = 0 + + do i=1, nza + if (a%ia(i) == idx) then + res = res + 1 + end if + end do + + end if + +end function psb_lz_coo_get_nz_row + +! == ================================== +! +! +! +! Data management +! +! +! +! +! +! == ================================== + + + +subroutine psb_lz_coo_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csgetptn + implicit none + + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = iren(a%ia(i)) + ja(nzin_) = iren(a%ja(i)) + end if + enddo + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nzin_ = nzin_ + 1 + nz = nz + 1 + ia(nzin_) = a%ia(i) + ja(nzin_) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + end if + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info /= psb_success_) return + + end if + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + nzin_=nzin_+k + end if + nz = k + end if + + end subroutine coo_getptn + +end subroutine psb_lz_coo_csgetptn + + +! +! NZ is the number of non-zeros on output. +! The output is guaranteed to be sorted +! +subroutine psb_lz_coo_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csgetrow + implicit none + + class(psb_lz_coo_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax= psb_debug_serial_)& + & write(debug_unit,*) trim(name), ': srtdcoo ' + do + ip = psb_bsrch(irw,inza,a%ia) + if (ip /= -1) exit + irw = irw + 1 + if (irw > imax) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error? ',& + & irw,lrw,imin + exit + end if + end do + + if (ip /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (ip < 2) exit + if (a%ia(ip-1) == irw) then + ip = ip -1 + else + exit + end if + end do + + end if + + do + jp = psb_bsrch(lrw,inza,a%ia) + if (jp /= -1) exit + lrw = lrw - 1 + if (irw > lrw) then + write(debug_unit,*) trim(name),& + & 'Warning : did not find any rows. Is this an error?' + exit + end if + end do + + if (jp /= -1) then + ! expand [ip,jp] to contain all row entries. + do + if (jp == nza) exit + if (a%ia(jp+1) == lrw) then + jp = jp + 1 + else + exit + end if + end do + end if + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza + if ((ip /= -1) .and.(jp /= -1)) then + ! Now do the copy. + nzt = jp - ip +1 + nz = 0 + + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = iren(a%ia(i)) + ja(nzin_+nz) = iren(a%ja(i)) + end if + enddo + call psb_lz_fix_coo_inner(nra,nca,nzin_+nz,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + else + do i=ip,jp + if ((jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + nz = nz + 1 + val(nzin_+nz) = a%val(i) + ia(nzin_+nz) = a%ia(i) + ja(nzin_+nz) = a%ja(i) + end if + enddo + end if + else + nz = 0 + end if + + else + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': unsorted ' + + nrd = max(a%get_nrows(),1) + nzt = ((nza+nrd-1)/nrd)*(lrw-irw+1) + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + if (present(iren)) then + k = 0 + do i=1, a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = iren(a%ia(i)) + ja(nzin_+k) = iren(a%ja(i)) + endif + enddo + else + k = 0 + do i=1,a%get_nzeros() + if ((a%ia(i)>=irw).and.(a%ia(i)<=lrw).and.& + & (jmin <= a%ja(i)).and.(a%ja(i)<=jmax)) then + k = k + 1 + if (k > nzt) then + nzt = k + nzt + call psb_ensure_size(nzin_+nzt,ia,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,ja,info) + if (info == psb_success_) call psb_ensure_size(nzin_+nzt,val,info) + if (info /= psb_success_) return + + end if + val(nzin_+k) = a%val(i) + ia(nzin_+k) = (a%ia(i)) + ja(nzin_+k) = (a%ja(i)) + endif + enddo + end if + call psb_lz_fix_coo_inner(nra,nca,nzin_+k,psb_dupl_add_,ia,ja,val,nz,info) + nz = nz - nzin_ + end if + + end subroutine coo_getrow + +end subroutine psb_lz_coo_csgetrow + + +subroutine psb_lz_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_sort_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_csput_a + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_coo_csput_a_impl' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (nz < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/1_psb_ipk_/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/2_psb_ipk_/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/3_psb_ipk_/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + call psb_errpush(info,name,i_err=(/4_psb_ipk_/)) + goto 9999 + end if + + if (nz == 0) return + + + nza = a%get_nzeros() + isza = a%get_size() + if (a%is_bld()) then + ! Build phase. Must handle reallocations in a sensible way. + if (isza < (nza+nz)) then + call a%reallocate(max(nza+nz,int(1.5*isza))) + endif + isza = a%get_size() + if (isza < (nza+nz)) then + info = psb_err_alloc_dealloc_; call psb_errpush(info,name) + goto 9999 + end if + + call psb_inner_ins(nz,ia,ja,val,nza,a%ia,a%ja,a%val,isza,& + & imin,imax,jmin,jmax,info,gtl) + call a%set_nzeros(nza) + call a%set_sorted(.false.) + + + else if (a%is_upd()) then + + if (a%is_dev()) call a%sync() + + call lz_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& + & imin,imax,jmin,jmax,info,gtl) + implicit none + + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax,maxsz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + integer(psb_lpk_), intent(inout) :: nza,ia1(:),ia2(:) + complex(psb_dpk_), intent(in) :: val(:) + complex(psb_dpk_), intent(inout) :: aspk(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic,ng + + info = psb_success_ + if (present(gtl)) then + ng = size(gtl) + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end if + end do + else + + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then + nza = nza + 1 + ia1(nza) = ir + ia2(nza) = ic + aspk(nza) = val(i) + end if + end do + end if + + end subroutine psb_inner_ins + + + subroutine lz_coo_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nnz,dupl,ng, nr + integer(psb_ipk_) :: debug_level, debug_unit, innz, nc + character(len=20) :: name='lz_coo_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + innz = nnz + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + if ((ir > 0).and.(ir <= nr)) then + ic = gtl(ic) + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + endif + else + info = max(info,1) + end if + end do + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + + if (ir /= ilr) then + i1 = psb_bsrch(ir,innz,a%ia) + i2 = i1 + do + if (i2+1 > nnz) exit + if (a%ia(i2+1) /= a%ia(i2)) exit + i2 = i2 + 1 + end do + do + if (i1-1 < 1) exit + if (a%ia(i1-1) /= a%ia(i1)) exit + i1 = i1 - 1 + end do + ilr = ir + else + i1 = 1 + i2 = 1 + end if + nc = i2-i1+1 + ip = psb_ssrch(ic,nc,a%ja(i1:i2)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine lz_coo_srch_upd + +end subroutine psb_lz_coo_csput_a + + +subroutine psb_lz_cp_coo_to_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_coo + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_to_coo + +subroutine psb_lz_cp_coo_from_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_coo + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_from_coo + + +subroutine psb_lz_cp_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_fmt + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_to_fmt + +subroutine psb_lz_cp_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_fmt + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%cp_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_from_fmt + + +subroutine psb_lz_mv_coo_to_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_to_coo + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call b%set_sort_status(a%get_sort_status()) + call b%set_nzeros(a%get_nzeros()) + + call move_alloc(a%ia, b%ia) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call b%set_host() + call a%free() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_mv_coo_to_coo + +subroutine psb_lz_mv_coo_from_coo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_from_coo + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + call a%set_nzeros(b%get_nzeros()) + + call move_alloc(b%ia , a%ia ) + call move_alloc(b%ja , a%ja ) + call move_alloc(b%val, a%val ) + call b%free() + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_mv_coo_from_coo + + +subroutine psb_lz_mv_coo_to_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_to_fmt + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_from_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_mv_coo_to_fmt + +subroutine psb_lz_mv_coo_from_fmt(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_mv_coo_from_fmt + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + + call psb_erractionsave(err_act) + info = psb_success_ + + call b%mv_to_coo(a,info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_mv_coo_from_fmt + +subroutine psb_lz_coo_cp_from(a,b) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_cp_from + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + type(psb_lz_coo_sparse_mat), intent(in) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%cp_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_cp_from + +subroutine psb_lz_coo_mv_from(a,b) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_coo_mv_from + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + type(psb_lz_coo_sparse_mat), intent(inout) :: b + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='mv_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call a%mv_from_coo(b,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_coo_mv_from + + + +subroutine psb_lz_fix_coo(a,info,idir) + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_fix_coo + implicit none + + class(psb_lz_coo_sparse_mat), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + integer(psb_lpk_), allocatable :: iaux(:) + !locals + integer(psb_lpk_) :: nza, nzl,iret, nra, nca + integer(psb_lpk_) :: i,j, irw, icl + integer(psb_ipk_) :: debug_level, debug_unit, err_act, dupl_, idir_ + character(len=20) :: name = 'psb_fixcoo' + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(a%ia),size(a%ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + if (a%is_dev()) call a%sync() + + nra = a%get_nrows() + nca = a%get_ncols() + nza = a%get_nzeros() + if (nza >= 2) then + dupl_ = a%get_dupl() + call psb_lz_fix_coo_inner(nra,nca,nza,dupl_,a%ia,a%ja,a%val,i,info,idir_) + if (info /= psb_success_) goto 9999 + else + i = nza + end if + call a%set_sort_status(idir_) + call a%set_nzeros(i) + call a%set_asb() + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_fix_coo + + + +subroutine psb_lz_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir) + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_fix_coo_inner + use psb_string_mod + use psb_ip_reord_mod + use psb_sort_mod + implicit none + + integer(psb_lpk_), intent(in) :: nr, nc, nzin, dupl + integer(psb_lpk_), intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), intent(inout) :: val(:) + integer(psb_lpk_), intent(out) :: nzout + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: idir + !locals + integer(psb_lpk_), allocatable :: iaux(:), ias(:),jas(:), ix2(:) + complex(psb_dpk_), allocatable :: vs(:) + integer(psb_lpk_) :: nza + integer(psb_ipk_) :: iret, nzl,idir_, dupl_, err_act, inzin + integer(psb_lpk_) :: i,j, irw, icl, ip,is, imx, k, ii + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name = 'psb_fixcoo' + logical :: srt_inp, use_buffers + + info = psb_success_ + + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if(debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),': start ',& + & size(ia),size(ja) + if (present(idir)) then + idir_ = idir + else + idir_ = psb_row_major_ + endif + + + if (nzin < 2) then + call psb_erractionrestore(err_act) + return + end if + + dupl_ = dupl + + + + allocate(iaux(max(nr,nc,nzin)+2),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + allocate(ias(nzin),jas(nzin),vs(nzin),ix2(max(nr,nc,nzin)+2), stat=info) + use_buffers = (info == 0) + + select case(idir_) + + case(psb_row_major_) + ! Row major order + if (use_buffers) then + if (.not.( (ia(1) < 1).or.(ia(1)> nr)) ) then + iaux(:) = 0 + iaux(ia(1)) = iaux(ia(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ia(i) < 1).or.(ia(i)> nr)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ia(i)) = iaux(ia(i)) + 1 + srt_inp = srt_inp .and.(ia(i-1)<=ia(i)) + end do + else + use_buffers=.false. + end if + end if + ! Check again use_buffers. + if (use_buffers) then + if (srt_inp) then + ! If input was already row-major + ! we can do it row-by-row here. + k = 0 + i = 1 + do j=1, nr + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ja(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already row-major + ! we have to sort all + + ip = iaux(1) + iaux(1) = 0 + do i=2, nr + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nr+1) = ip + + do i=1,nzin + irw = ia(i) + ip = iaux(irw) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(irw) = ip + end do + k = 0 + i = 1 + do j=1, nr + + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,jas(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + ! + ! If we did not have enough memory for buffers, + ! let's try in place. + ! + inzin = nzin + call psi_msort_up(inzin,ia(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + + do while ((ia(j) == ia(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ja(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + select case(dupl_) + case(psb_dupl_ovwrt_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + endif + + if(debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + + case(psb_col_major_) + + if (use_buffers) then + iaux(:) = 0 + if (.not.( (ja(1) < 1).or.(ja(1)> nc)) ) then + iaux(ja(1)) = iaux(ja(1)) + 1 + srt_inp = .true. + do i=2,nzin + if ( (ja(i) < 1).or.(ja(i)> nc)) then + use_buffers = .false. + srt_inp = .false. + exit + end if + iaux(ja(i)) = iaux(ja(i)) + 1 + srt_inp = srt_inp .and.(ja(i-1)<=ja(i)) + end do + else + use_buffers=.false. + end if + end if + !use_buffers=use_buffers.and.srt_inp + ! Check again use_buffers. + if (use_buffers) then + + if (srt_inp) then + ! If input was already col-major + ! we can do it col-by-col here. + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j) + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ia(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:imx),& + & ia(i:imx),ja(i:imx),ix2) + + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + val(k) = val(k) + val(i) + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ia(i) + ja(k) = ja(i) + val(k) = val(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ia(i) == irw).and.(ja(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = val(i) + ia(k) = ia(i) + ja(k) = ja(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + !i = i + nzl + enddo + + else if (.not.srt_inp) then + ! If input was not already col-major + ! we have to sort all + ip = iaux(1) + iaux(1) = 0 + do i=2, nc + is = iaux(i) + iaux(i) = ip + ip = ip + is + end do + iaux(nc+1) = ip + + do i=1,nzin + icl = ja(i) + ip = iaux(icl) + 1 + ias(ip) = ia(i) + jas(ip) = ja(i) + vs(ip) = val(i) + iaux(icl) = ip + end do + k = 0 + i = 1 + do j=1, nc + nzl = iaux(j)-i+1 + imx = i+nzl-1 + + if (nzl > 0) then + call psi_msort_up(nzl,ias(i:imx),ix2,iret) + if (iret == 0) & + & call psb_ip_reord(nzl,vs(i:imx),& + & ias(i:imx),jas(i:imx),ix2) + select case(dupl_) + case(psb_dupl_ovwrt_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_add_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + val(k) = val(k) + vs(i) + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + + case(psb_dupl_err_) + k = k + 1 + ia(k) = ias(i) + ja(k) = jas(i) + val(k) = vs(i) + irw = ia(k) + icl = ja(k) + do + i = i + 1 + if (i > imx) exit + if ((ias(i) == irw).and.(jas(i) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + k = k+1 + val(k) = vs(i) + ia(k) = ias(i) + ja(k) = jas(i) + irw = ia(k) + icl = ja(k) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + return + end select + + endif + enddo + + end if + + i=k + deallocate(ias,jas,vs,ix2, stat=info) + + else if (.not.use_buffers) then + + inzin = nzin + call psi_msort_up(inzin,ja(1:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(inzin,val,ia,ja,iaux) + i = 1 + j = i + do while (i <= nzin) + do while ((ja(j) == ja(i))) + j = j+1 + if (j > nzin) exit + enddo + nzl = j - i + call psi_msort_up(nzl,ia(i:),iaux(1:),iret) + if (iret == 0) & + & call psb_ip_reord(nzl,val(i:i+nzl-1),& + & ia(i:i+nzl-1),ja(i:i+nzl-1),iaux) + i = j + enddo + + i = 1 + irw = ia(i) + icl = ja(i) + j = 1 + + + select case(dupl_) + case(psb_dupl_ovwrt_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_add_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + val(i) = val(i) + val(j) + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + + case(psb_dupl_err_) + do + j = j + 1 + if (j > nzin) exit + if ((ia(j) == irw).and.(ja(j) == icl)) then + call psb_errpush(psb_err_duplicate_coo,name) + goto 9999 + else + i = i+1 + val(i) = val(j) + ia(i) = ia(j) + ja(i) = ja(j) + irw = ia(i) + icl = ja(i) + endif + enddo + case default + write(psb_err_unit,*) 'Error in fix_coo: unsafe dupl',dupl_ + info =-7 + end select + if (debug_level >= psb_debug_serial_)& + & write(debug_unit,*) trim(name),': end second loop' + + end if + + case default + write(debug_unit,*) trim(name),': unknown direction ',idir_ + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end select + + nzout = i + + deallocate(iaux) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_fix_coo_inner + + +subroutine psb_lz_cp_coo_to_icoo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_to_icoo + implicit none + class(psb_lz_coo_sparse_mat), intent(in) :: a + class(psb_z_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: nz + character(len=20) :: name='to_coo' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = psb_success_ + if (a%is_dev()) call a%sync() + + b%psb_base_sparse_mat = a%psb_lbase_sparse_mat + call b%set_sort_status(a%get_sort_status()) + nz = a%get_nzeros() + call b%set_nzeros(nz) + call b%reallocate(nz) + + b%ia(1:nz) = a%ia(1:nz) + b%ja(1:nz) = a%ja(1:nz) + b%val(1:nz) = a%val(1:nz) + + call b%set_host() + + if (.not.b%is_by_rows()) call b%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_to_icoo + +subroutine psb_lz_cp_coo_from_icoo(a,b,info) + use psb_error_mod + use psb_z_base_mat_mod, psb_protect_name => psb_lz_cp_coo_from_icoo + implicit none + class(psb_lz_coo_sparse_mat), intent(inout) :: a + class(psb_z_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='from_coo' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: m,n,nz + + call psb_erractionsave(err_act) + info = psb_success_ + if (b%is_dev()) call b%sync() + a%psb_lbase_sparse_mat = b%psb_base_sparse_mat + call a%set_sort_status(b%get_sort_status()) + nz = b%get_nzeros() + call a%set_nzeros(nz) + call a%reallocate(nz) + + a%ia(1:nz) = b%ia(1:nz) + a%ja(1:nz) = b%ja(1:nz) + a%val(1:nz) = b%val(1:nz) + + call a%set_host() + + if (.not.a%is_by_rows()) call a%fix(info) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + + call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cp_coo_from_icoo + diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index 1abf68d3c..29c3e3929 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -2030,7 +2030,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2059,7 +2059,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2098,7 +2098,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2122,7 +2122,7 @@ contains i2 = a%icp(ic+1) nr=i2-i1 - ip = psb_ibsrch(ir,nr,a%ia(i1:i2-1)) + ip = psb_bsrch(ir,nr,a%ia(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2951,3 +2951,1901 @@ contains end subroutine csc_spspmm end subroutine psb_zcscspspmm + + + +subroutine psb_lz_csc_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_get_diag + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = zone + else + do i=1, mnm + d(i) = zzero + do k=a%icp(i),a%icp(i+1)-1 + j=a%ia(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + endif + do i=mnm+1,size(d) + d(i) = zzero + end do + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_get_diag + + +subroutine psb_lz_csc_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_scal + use psb_string_mod + implicit none + class(psb_lz_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, n + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_ipk_) :: err_act,ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + if (a%is_unit()) then + call a%make_nonunit() + end if + + left = (side_ == 'L') + + if (left) then + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, a%get_nzeros() + a%val(i) = a%val(i) * d(a%ia(i)) + enddo + else + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do j=1, n + do i = a%icp(j), a%icp(j+1) -1 + a%val(i) = a%val(i) * d(j) + end do + enddo + end if + call a%set_host() + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_scal + + +subroutine psb_lz_csc_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_scals + implicit none + class(psb_lz_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act,ierr(5) + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_scals + + +function psb_lz_csc_maxval(a) result(res) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_maxval + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: nnz + character(len=20) :: name='lz_csc_maxval' + logical, parameter :: debug=.false. + + + if (a%is_unit()) then + res = done + else + res = dzero + end if + if (a%is_dev()) call a%sync() + + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_lz_csc_maxval + +function psb_lz_csc_csnm1(a) result(res) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csnm1 + + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc, info + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_csc_csnm1' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + m = a%get_nrows() + n = a%get_ncols() + is_unit = a%is_unit() + do j=1, n + if (is_unit) then + acc = done + else + acc = dzero + end if + do k=a%icp(j),a%icp(j+1)-1 + acc = acc + abs(a%val(k)) + end do + res = max(res,acc) + end do + + return + +end function psb_lz_csc_csnm1 + +subroutine psb_lz_csc_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_colsum + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = zone + else + d(i) = zzero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_colsum + +subroutine psb_lz_csc_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_aclsum + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_lpk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra, is_unit + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + is_unit = a%is_unit() + do i = 1, a%get_ncols() + if (is_unit) then + d(i) = done + else + d(i) = dzero + end if + + do j=a%icp(i),a%icp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, a%get_ncols() + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_aclsum + +subroutine psb_lz_csc_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_rowsum + class(psb_lz_csc_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = zone + else + d = zzero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + (a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_rowsum + +subroutine psb_lz_csc_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_arwsum + class(psb_lz_csc_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,nnz, ir, jc, nc + integer(psb_epk_) :: m,n + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_ncols() + n = a%get_nrows() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + if (a%is_unit()) then + d = done + else + d = dzero + end if + + do i=1, m + do j=a%icp(i),a%icp(i+1)-1 + k = a%ia(j) + d(k) = d(k) + abs(a%val(k)) + end do + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_arwsum + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + +subroutine psb_lz_csc_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csgetptn + implicit none + + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + isz = min(size(ia),size(ja)) + end if + nz = nz + 1 + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + + end subroutine lcsc_getptn + +end subroutine psb_lz_csc_csgetptn + + + + +subroutine psb_lz_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csgetrow + implicit none + + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + + if ((imaxisz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + call psb_ensure_size(int(1.25*nzin_)+ione,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = iren(a%ia(j)) + ja(nzin_) = iren(i) + end if + enddo + end do + else + do i=icl, lcl + do j=a%icp(i), a%icp(i+1) - 1 + if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then + nzin_ = nzin_ + 1 + if (nzin_>isz) then + call psb_ensure_size(int(1.25*nzin_)+ione,ia,info) + call psb_ensure_size(int(1.25*nzin_)+ione,ja,info) + call psb_ensure_size(int(1.25*nzin_)+ione,val,info) + isz = min(size(ia),size(ja),size(val)) + end if + nz = nz + 1 + val(nzin_) = a%val(j) + ia(nzin_) = (a%ia(j)) + ja(nzin_) = (i) + end if + enddo + end do + end if + end subroutine lcsc_getrow + +end subroutine psb_lz_csc_csgetrow + + + +subroutine psb_lz_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csput_a + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act, debug_level, debug_unit, ierr(5) + character(len=20) :: name='lz_csc_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + info = psb_success_ + + if (nz <= 0) then + info = psb_err_iarg_neg_ + ierr(1)=1 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=2 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=3 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_ + ierr(1)=4 + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (nz == 0) return + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_lz_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_lz_csc_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,dupl,ng, nar, nac + integer(psb_ipk_) :: debug_level, debug_unit, inr + character(len=20) :: name='lz_csc_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nar = a%get_nrows() + nac = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ic > 0).and.(ic <= nac)) then + i1 = a%icp(ic) + i2 = a%icp(ic+1) + nr = i2-i1 + inr = nr + ip = psb_bsrch(ir,inr,a%ia(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_lz_csc_srch_upd + +end subroutine psb_lz_csc_csput_a + + +subroutine psb_lz_cp_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_cp_csc_from_coo + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + ! We need to make a copy because mv_from will have to + ! sort in column-major order. + call tmp%cp_from_coo(b,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + +end subroutine psb_lz_cp_csc_from_coo + + + +subroutine psb_lz_cp_csc_to_coo(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_cp_csc_to_coo + implicit none + + class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ia(j) = a%ia(j) + b%ja(j) = i + b%val(j) = a%val(j) + end do + end do + + call b%set_nzeros(a%get_nzeros()) + call b%fix(info) + + +end subroutine psb_lz_cp_csc_to_coo + + +subroutine psb_lz_mv_csc_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_mv_csc_to_coo + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ia,b%ia) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ja,info) + if (info /= psb_success_) return + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + b%ja(j) = i + end do + end do + call a%free() + call b%fix(info) + +end subroutine psb_lz_mv_csc_to_coo + + +subroutine psb_lz_mv_csc_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_mv_csc_from_coo + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + integer(psb_lpk_) :: nza, nr, i,j,k,ip,irw, nc, nrl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name='lz_mv_csc_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + + call b%fix(info, idir=psb_col_major_) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ja,itemp) + call move_alloc(b%ia,a%ia) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%icp,info) + call b%free() + + a%icp(:) = 0 + do k=1,nza + i = itemp(k) + a%icp(i) = a%icp(i) + 1 + end do + ip = 1 + do i=1,nc + nrl = a%icp(i) + a%icp(i) = ip + ip = ip + nrl + end do + a%icp(nc+1) = ip + call a%set_host() + + +end subroutine psb_lz_mv_csc_from_coo + + +subroutine psb_lz_mv_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_mv_csc_to_fmt + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_lz_csc_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call move_alloc(a%icp, b%icp) + call move_alloc(a%ia, b%ia) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lz_mv_csc_to_fmt +!!$ + +subroutine psb_lz_cp_csc_to_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_cp_csc_to_fmt + implicit none + + class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_lz_csc_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + nc = a%get_ncols() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%icp(1:nc+1), b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia(1:nz), b%ia , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lz_cp_csc_to_fmt + + +subroutine psb_lz_mv_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_mv_csc_from_fmt + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_lz_csc_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + call move_alloc(b%icp, a%icp) + call move_alloc(b%ia, a%ia) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + call a%set_host() + +end subroutine psb_lz_mv_csc_from_fmt + + + +subroutine psb_lz_cp_csc_from_fmt(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_cp_csc_from_fmt + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: err_act, debug_level, debug_unit + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_lz_csc_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + nc = b%get_ncols() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%icp(1:nc+1), a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia(1:nz), a%ia , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz), a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + call a%set_host() + +end subroutine psb_lz_cp_csc_from_fmt + + +subroutine psb_lz_csc_mold(a,b,info) + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_mold + use psb_error_mod + implicit none + class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csc_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lz_csc_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_mold + +subroutine psb_lz_csc_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_reallocate_nz + implicit none + integer(psb_ipk_), intent(in) :: nz + class(psb_lz_csc_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='lz_csc_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ia,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(max(nz,a%get_nrows()+1,& + & a%get_ncols()+1), a%icp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_reallocate_nz + + + +subroutine psb_lz_csc_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_csgetblk + implicit none + + class(psb_lz_csc_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + integer(psb_lpk_) :: nzin, nzout + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='csget' + logical :: append_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(append)) then + append_ = append + else + append_ = .false. + endif + if (append_) then + nzin = a%get_nzeros() + else + nzin = 0 + endif + + call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,& + & jmin=jmin, jmax=jmax, iren=iren, append=append_, & + & nzin=nzin, rscale=rscale, cscale=cscale) + + if (info /= psb_success_) goto 9999 + + call b%set_nzeros(nzin+nzout) + call b%fix(info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_csgetblk + +subroutine psb_lz_csc_reinit(a,clear) + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_reinit + implicit none + + class(psb_lz_csc_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_reinit + +subroutine psb_lz_csc_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_trim + implicit none + class(psb_lz_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, n + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + n = a%get_ncols() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz,a%ia,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_trim + +subroutine psb_lz_csc_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_csc_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info, ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(n+1,a%icp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ia,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%icp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csc_allocate_mnnz + +subroutine psb_lz_csc_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_z_csc_mat_mod, psb_protect_name => psb_lz_csc_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_csc_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='lz_csc_print' + logical, parameter :: debug=.false. + + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_ipk_) :: i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) iv(a%ia(j)),iv(i),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),i,a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) ivr(a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),ivc(i),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nc + do j=a%icp(i),a%icp(i+1)-1 + write(iout,frmtv) (a%ia(j)),(i),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_lz_csc_print + +subroutine psb_lzcscspspmm(a,b,c,info) + use psb_z_mat_mod + use psb_serial_mod, psb_protect_name => psb_lzcscspspmm + + implicit none + + class(psb_lz_csc_sparse_mat), intent(in) :: a,b + type(psb_lz_csc_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_cscspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + + call csc_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csc_spspmm(a,b,c,info) + implicit none + type(psb_lz_csc_sparse_mat), intent(in) :: a,b + type(psb_lz_csc_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: icol(:), idxs(:), iaux(:) + complex(psb_dpk_), allocatable :: col(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + complex(psb_dpk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ia)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,col,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,icol,info) + if (info /= 0) return + col = dzero + icol = 0 + nzc = 1 + do j = 1,nb + c%icp(j) = nzc + nrc = 0 + do k = b%icp(j), b%icp(j+1)-1 + icl = b%ia(k) + cfb = b%val(k) + irwsz = a%icp(icl+1)-a%icp(icl) + do i = a%icp(icl),a%icp(icl+1)-1 + irw = a%ia(i) + if (icol(irw) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(nb*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ia,info) + if (info /= 0) return + end if + call psb_msort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ia(nzc) = irw + c%val(nzc) = col(irw) + col(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%icp(nb+1) = nzc + + end subroutine csc_spspmm + +end subroutine psb_lzcscspspmm diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index 502b7c5bf..808a407a8 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -1018,7 +1018,6 @@ subroutine psb_z_csr_cssm(alpha,a,x,beta,y,info,trans) complex(psb_dpk_), allocatable :: tmp(:,:) logical :: tra, ctra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_csr_cssm' logical, parameter :: debug=.false. @@ -1269,8 +1268,8 @@ function psb_z_csr_maxval(a) result(res) class(psb_z_csr_sparse_mat), intent(in) :: a real(psb_dpk_) :: res - integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc, info - integer(psb_ipk_) :: ierr(5) + integer(psb_ipk_) :: i,j,k,m,n, nnz, ir, jc, nc + integer(psb_ipk_) :: info character(len=20) :: name='z_csr_maxval' logical, parameter :: debug=.false. @@ -1295,7 +1294,6 @@ function psb_z_csr_csnmi(a) result(res) real(psb_dpk_) :: acc logical :: tra integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_csnmi' logical, parameter :: debug=.false. @@ -1655,7 +1653,6 @@ subroutine psb_z_csr_scals(d,a,info) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act,mnm, i, j, m - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='scal' logical, parameter :: debug=.false. @@ -1704,7 +1701,6 @@ subroutine psb_z_csr_reallocate_nz(nz,a) integer(psb_ipk_), intent(in) :: nz class(psb_z_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_csr_reallocate_nz' logical, parameter :: debug=.false. @@ -1736,7 +1732,6 @@ subroutine psb_z_csr_mold(a,b,info) class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csr_mold' logical, parameter :: debug=.false. @@ -1846,7 +1841,6 @@ subroutine psb_z_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& logical :: append_, rscale_, cscale_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2021,7 +2015,6 @@ subroutine psb_z_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,& logical :: append_, rscale_, cscale_, chksz_ integer(psb_ipk_) :: nzin_, jmin_, jmax_, err_act, i - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='csget' logical, parameter :: debug=.false. @@ -2206,8 +2199,6 @@ subroutine psb_z_csr_tril(a,l,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_), allocatable :: ia(:), ja(:) - complex(psb_dpk_), allocatable :: val(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='tril' logical :: rscale_, cscale_ @@ -2362,8 +2353,6 @@ subroutine psb_z_csr_triu(a,u,info,& integer(psb_ipk_) :: err_act, nzin, nzout, i, j, k integer(psb_ipk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz - integer(psb_ipk_), allocatable :: ia(:), ja(:) - complex(psb_dpk_), allocatable :: val(:) integer(psb_ipk_) :: ierr(5) character(len=20) :: name='triu' logical :: rscale_, cscale_ @@ -2515,7 +2504,6 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_csr_csput_a' logical, parameter :: debug=.false. integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit @@ -2527,28 +2515,24 @@ subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) debug_level = psb_get_debug_level() if (nz <= 0) then - info = psb_err_iarg_neg_ - ierr(1)=1 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_iarg_neg_; i=1 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(ia) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=2 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=2 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(ja) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=3 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=3 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if if (size(val) < nz) then - info = psb_err_input_asize_invalid_i_ - ierr(1)=4 - call psb_errpush(info,name,i_err=ierr) + info = psb_err_input_asize_invalid_i_; i=4 + call psb_errpush(info,name,i_err=(/i/)) goto 9999 end if @@ -2652,7 +2636,7 @@ contains i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2680,7 +2664,7 @@ contains i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2720,7 +2704,7 @@ contains i2 = a%irp(ir+1) nc=i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = val(i) else @@ -2742,7 +2726,7 @@ contains i1 = a%irp(ir) i2 = a%irp(ir+1) nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1)) + ip = psb_bsrch(ic,nc,a%ja(i1:i2-1)) if (ip>0) then a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) else @@ -2776,7 +2760,6 @@ subroutine psb_z_csr_reinit(a,clear) logical, intent(in), optional :: clear integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='reinit' logical :: clear_ logical, parameter :: debug=.false. @@ -2821,7 +2804,6 @@ subroutine psb_z_csr_trim(a) implicit none class(psb_z_csr_sparse_mat), intent(inout) :: a integer(psb_ipk_) :: err_act, info, nz, m - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='trim' logical, parameter :: debug=.false. @@ -2856,7 +2838,6 @@ subroutine psb_z_csr_print(iout,a,iv,head,ivr,ivc) integer(psb_ipk_), intent(in), optional :: ivr(:), ivc(:) integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: ierr(5) character(len=20) :: name='z_csr_print' logical, parameter :: debug=.false. character(len=*), parameter :: datatype='complex' @@ -3446,3 +3427,2179 @@ contains end subroutine csr_spspmm end subroutine psb_zcsrspspmm + + +! +! +! lz version +! +! +subroutine psb_lz_csr_get_diag(a,d,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_get_diag + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, k + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + mnm = min(a%get_nrows(),a%get_ncols()) + if (size(d) < mnm) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + + if (a%is_unit()) then + d(1:mnm) = zone + else + do i=1, mnm + d(i) = zzero + do k=a%irp(i),a%irp(i+1)-1 + j=a%ja(k) + if ((j == i) .and.(j <= mnm )) then + d(i) = a%val(k) + endif + enddo + end do + end if + do i=mnm+1,size(d) + d(i) = zzero + end do + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lz_csr_get_diag + + +subroutine psb_lz_csr_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_scal + use psb_string_mod + implicit none + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act, ierr(5) + character(len=20) :: name='scal' + character :: side_ + logical :: left + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + side_ = 'L' + if (present(side)) then + side_ = psb_toupper(side) + end if + + left = (side_ == 'L') + + if (left) then + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1, m + do j = a%irp(i), a%irp(i+1) -1 + a%val(j) = a%val(j) * d(i) + end do + enddo + else + m = a%get_ncols() + if (size(d) < m) then + info=psb_err_input_asize_invalid_i_ + ierr(1) = 2; ierr(2) = size(d); + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + do i=1,a%get_nzeros() + j = a%ja(i) + a%val(i) = a%val(i) * d(j) + enddo + end if + + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lz_csr_scal + + +subroutine psb_lz_csr_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_scals + implicit none + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_) :: mnm, i, j, m + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + if (a%is_unit()) then + call a%make_nonunit() + end if + + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + call a%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lz_csr_scals + + +function psb_lz_csr_maxval(a) result(res) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_maxval + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: nnz + integer(psb_ipk_) :: info + character(len=20) :: name='lz_csr_maxval' + logical, parameter :: debug=.false. + + if (a%is_dev()) call a%sync() + + res = dzero + nnz = a%get_nzeros() + if (allocated(a%val)) then + nnz = min(nnz,size(a%val)) + res = maxval(abs(a%val(1:nnz))) + end if +end function psb_lz_csr_maxval + +function psb_lz_csr_csnmi(a) result(res) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csnmi + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_lpk_) :: i,j,k,m,n, nr, ir, jc, nc + real(psb_dpk_) :: acc + logical :: tra + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_csnmi' + logical, parameter :: debug=.false. + + + res = dzero + if (a%is_dev()) call a%sync() + + do i = 1, a%get_nrows() + acc = dzero + do j=a%irp(i),a%irp(i+1)-1 + acc = acc + abs(a%val(j)) + end do + res = max(res,acc) + end do + +end function psb_lz_csr_csnmi + +subroutine psb_lz_csr_rowsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_rowsum + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + do i = 1, a%get_nrows() + d(i) = zzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + zone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_rowsum + +subroutine psb_lz_csr_arwsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_arwsum + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + if (size(d) < m) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = m + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + + do i = 1, a%get_nrows() + d(i) = dzero + do j=a%irp(i),a%irp(i+1)-1 + d(i) = d(i) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, m + d(i) = d(i) + done + end do + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_arwsum + +subroutine psb_lz_csr_colsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_colsum + class(psb_lz_csr_sparse_mat), intent(in) :: a + complex(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + complex(psb_dpk_) :: acc + complex(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = zzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + (a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + zone + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_colsum + +subroutine psb_lz_csr_aclsum(d,a) + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_aclsum + class(psb_lz_csr_sparse_mat), intent(in) :: a + real(psb_dpk_), intent(out) :: d(:) + + integer(psb_lpk_) :: i,j,k,m,n, nnz, ir, jc, nc + real(psb_dpk_) :: acc + real(psb_dpk_), allocatable :: vt(:) + logical :: tra + integer(psb_ipk_) :: err_act, info + integer(psb_epk_) :: err(5) + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + + m = a%get_nrows() + n = a%get_ncols() + if (size(d) < n) then + info=psb_err_input_asize_small_i_ + err(1) = 1; err(2) = size(d); err(3) = n + call psb_errpush(info,name,e_err=err) + goto 9999 + end if + + d = dzero + + do i=1, m + do j=a%irp(i),a%irp(i+1)-1 + k = a%ja(j) + d(k) = d(k) + abs(a%val(j)) + end do + end do + + if (a%is_unit()) then + do i=1, n + d(i) = d(i) + done + end do + end if + + return + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_aclsum + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_lz_csr_reallocate_nz(nz,a) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_reallocate_nz + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='lz_csr_reallocate_nz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + + call psb_realloc(max(nz,ione),a%ja,info) + if (info == psb_success_) call psb_realloc(max(nz,ione),a%val,info) + if (info == psb_success_) call psb_realloc(& + & max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_reallocate_nz + +subroutine psb_lz_csr_mold(a,b,info) + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_mold + use psb_error_mod + implicit none + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + character(len=20) :: name='csr_mold' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_lz_csr_sparse_mat :: b, stat=info) + + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + return + +9999 call psb_error_handler(err_act) + return + +end subroutine psb_lz_csr_mold + +subroutine psb_lz_csr_allocate_mnnz(m,n,a,nz) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_allocate_mnnz + implicit none + integer(psb_lpk_), intent(in) :: m,n + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in), optional :: nz + integer(psb_lpk_) :: nz_ + integer(psb_ipk_) :: err_act, info + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = ione; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + if (present(nz)) then + nz_ = max(nz,ione) + else + nz_ = max(7*m,7*n,ione) + end if + if (nz_ < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 3; ierr(2) = izero; + call psb_errpush(info,name,i_err=ierr) + goto 9999 + endif + + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + if (info == psb_success_) call psb_realloc(nz_,a%ja,info) + if (info == psb_success_) call psb_realloc(nz_,a%val,info) + if (info == psb_success_) then + a%irp=0 + call a%set_nrows(m) + call a%set_ncols(n) + call a%set_bld() + call a%set_triangle(.false.) + call a%set_unit(.false.) + call a%set_dupl(psb_dupl_def_) + call a%set_host() + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_allocate_mnnz + + +subroutine psb_lz_csr_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csgetptn + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_lz_csr_csgetrow + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + logical :: append_, rscale_, cscale_ + integer(psb_lpk_) :: nzin_, jmin_, jmax_, i + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (a%is_dev()) call a%sync() + info = psb_success_ + nz = 0 + + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + endif + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + endif + + if ((imax psb_lz_csr_tril + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: u + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='tril' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call l%allocate(mb,nb,nz) + + if (present(u)) then + nzlin = l%get_nzeros() ! At this point it should be 0 + call u%allocate(mb,nb,nz) + nzuin = u%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzlin = nzlin + 1 + l%ia(nzlin) = i + l%ja(nzlin) = ja(k) + l%val(nzlin) = val(k) + else + nzuin = nzuin + 1 + u%ia(nzuin) = i + u%ja(nzuin) = ja(k) + u%val(nzuin) = val(k) + end if + end if + end do + end do + end associate + + call l%set_nzeros(nzlin) + call u%set_nzeros(nzuin) + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + if ((diag_ >=-1).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_lower(.false.) + end if + else + nzin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)<=diag_) then + nzin = nzin + 1 + l%ia(nzin) = i + l%ja(nzin) = ja(k) + l%val(nzin) = val(k) + end if + end if + end do + end do + end associate + call l%set_nzeros(nzin) + end if + call l%fix(info) + nzout = l%get_nzeros() + if (rscale_) & + & l%ia(1:nzout) = l%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & l%ja(1:nzout) = l%ja(1:nzout) - jmin_ + 1 + + if ((diag_ <= 0).and.(imin_ == jmin_)) then + call l%set_triangle(.true.) + call l%set_lower(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_tril + +subroutine psb_lz_csr_triu(a,u,info,& + & diag,imin,imax,jmin,jmax,rscale,cscale,l) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_triu + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(out) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lz_coo_sparse_mat), optional, intent(out) :: l + + integer(psb_ipk_) :: err_act + integer(psb_lpk_) :: nzin, nzout, i, j, k + integer(psb_lpk_) :: imin_, imax_, jmin_, jmax_, mb,nb, diag_, nzlin, nzuin, nz + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='triu' + logical :: rscale_, cscale_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (present(diag)) then + diag_ = diag + else + diag_ = 0 + end if + if (present(imin)) then + imin_ = imin + else + imin_ = 1 + end if + if (present(imax)) then + imax_ = imax + else + imax_ = a%get_nrows() + end if + if (present(jmin)) then + jmin_ = jmin + else + jmin_ = 1 + end if + if (present(jmax)) then + jmax_ = jmax + else + jmax_ = a%get_ncols() + end if + if (present(rscale)) then + rscale_ = rscale + else + rscale_ = .true. + end if + if (present(cscale)) then + cscale_ = cscale + else + cscale_ = .true. + end if + + if (rscale_) then + mb = imax_ - imin_ +1 + else + mb = imax_ + endif + if (cscale_) then + nb = jmax_ - jmin_ +1 + else + nb = jmax_ + endif + + + nz = a%get_nzeros() + call u%allocate(mb,nb,nz) + + if (present(l)) then + nzuin = u%get_nzeros() ! At this point it should be 0 + call l%allocate(mb,nb,nz) + nzlin = l%get_nzeros() ! At this point it should be 0 + associate(val =>a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + j = ja(k) + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)a%val, ja => a%ja, irp=>a%irp) + do i=imin_,imax_ + do k=irp(i),irp(i+1)-1 + if ((jmin_<=j).and.(j<=jmax_)) then + if ((ja(k)-i)>=diag_) then + nzin = nzin + 1 + u%ia(nzin) = i + u%ja(nzin) = ja(k) + u%val(nzin) = val(k) + end if + end if + end do + end do + end associate + call u%set_nzeros(nzin) + end if + call u%fix(info) + nzout = u%get_nzeros() + if (rscale_) & + & u%ia(1:nzout) = u%ia(1:nzout) - imin_ + 1 + if (cscale_) & + & u%ja(1:nzout) = u%ja(1:nzout) - jmin_ + 1 + + if ((diag_ >= 0).and.(imin_ == jmin_)) then + call u%set_triangle(.true.) + call u%set_upper(.true.) + end if + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_triu + + +subroutine psb_lz_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_error_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_csput_a + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_csr_csput_a' + logical, parameter :: debug=.false. + integer(psb_lpk_) :: nza, i,j,k, nzl, isza + integer(psb_ipk_) :: debug_level, debug_unit + + + call psb_erractionsave(err_act) + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (nz <= 0) then + info = psb_err_iarg_neg_; + call psb_errpush(info,name,m_err=(/1/)) + goto 9999 + end if + if (size(ia) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/2/)) + goto 9999 + end if + + if (size(ja) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/3/)) + goto 9999 + end if + if (size(val) < nz) then + info = psb_err_input_asize_invalid_i_; + call psb_errpush(info,name,m_err=(/4/)) + goto 9999 + end if + + if (nz == 0) return + if (a%is_dev()) call a%sync() + + nza = a%get_nzeros() + + if (a%is_bld()) then + ! Build phase should only ever be in COO + info = psb_err_invalid_mat_state_ + + else if (a%is_upd()) then + call psb_lz_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + if (info < 0) then + info = psb_err_internal_error_ + else if (info > 0) then + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Discarded entries not belonging to us.' + info = psb_success_ + end if + call a%set_host() + + else + ! State is wrong. + info = psb_err_invalid_mat_state_ + end if + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +contains + + subroutine psb_lz_csr_srch_upd(nz,ia,ja,val,a,& + & imin,imax,jmin,jmax,info,gtl) + + use psb_const_mod + use psb_realloc_mod + use psb_string_mod + use psb_sort_mod + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_lpk_), intent(in) :: ia(:),ja(:) + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + integer(psb_lpk_) :: i,ir,ic, ilr, ilc, ip, & + & i1,i2,nr,nc,nnz,ng + integer(psb_ipk_) :: debug_level, debug_unit,dupl, inc + character(len=20) :: name='lz_csr_srch_upd' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + dupl = a%get_dupl() + + if (.not.a%is_sorted()) then + info = -4 + return + end if + + ilr = -1 + ilc = -1 + nnz = a%get_nzeros() + nr = a%get_nrows() + nc = a%get_ncols() + + if (present(gtl)) then + ng = size(gtl) + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then + ir = gtl(ir) + ic = gtl(ic) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + else + info = max(info,1) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + else + + select case(dupl) + case(psb_dupl_ovwrt_,psb_dupl_err_) + ! Overwrite. + ! Cannot test for error, should have been caught earlier. + + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + + if ((ir > 0).and.(ir <= nr)) then + + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc=i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case(psb_dupl_add_) + ! Add + ilr = -1 + ilc = -1 + do i=1, nz + ir = ia(i) + ic = ja(i) + if ((ir > 0).and.(ir <= nr)) then + i1 = a%irp(ir) + i2 = a%irp(ir+1) + nc = i2-i1 + inc = nc + ip = psb_bsrch(ic,inc,a%ja(i1:i2-1)) + if (ip>0) then + a%val(i1+ip-1) = a%val(i1+ip-1) + val(i) + else + info = max(info,3) + end if + else + info = max(info,2) + end if + end do + + case default + info = -3 + if (debug_level >= psb_debug_serial_) & + & write(debug_unit,*) trim(name),& + & ': Duplicate handling: ',dupl + end select + + end if + + end subroutine psb_lz_csr_srch_upd + +end subroutine psb_lz_csr_csput_a + + +subroutine psb_lz_csr_reinit(a,clear) + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_reinit + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + logical, intent(in), optional :: clear + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + logical :: clear_ + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + + if (present(clear)) then + clear_ = clear + else + clear_ = .true. + end if + + if (a%is_bld() .or. a%is_upd()) then + ! do nothing + return + else if (a%is_asb()) then + if (clear_) a%val(:) = zzero + call a%set_upd() + call a%set_host() + else + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_reinit + +subroutine psb_lz_csr_trim(a) + use psb_realloc_mod + use psb_error_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_trim + implicit none + class(psb_lz_csr_sparse_mat), intent(inout) :: a + integer(psb_lpk_) :: nz, m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + m = a%get_nrows() + nz = a%get_nzeros() + if (info == psb_success_) call psb_realloc(m+1,a%irp,info) + + if (info == psb_success_) call psb_realloc(nz,a%ja,info) + if (info == psb_success_) call psb_realloc(nz,a%val,info) + + if (info /= psb_success_) goto 9999 + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csr_trim + +subroutine psb_lz_csr_print(iout,a,iv,head,ivr,ivc) + use psb_string_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_csr_print + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lz_csr_sparse_mat), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='lz_csr_print' + logical, parameter :: debug=.false. + character(len=*), parameter :: datatype='complex' + character(len=80) :: frmtv + integer(psb_lpk_) :: irs,ics,i,j, nmx, ni, nr, nc, nz + + + write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' + if (present(head)) write(iout,'(a,a)') '% ',head + write(iout,'(a)') '%' + write(iout,'(a,a)') '% COO' + + if (a%is_dev()) call a%sync() + + nr = a%get_nrows() + nc = a%get_ncols() + nz = a%get_nzeros() + nmx = max(nr,nc,1) + if (present(iv)) nmx = max(nmx,maxval(abs(iv))) + if (present(ivr)) nmx = max(nmx,maxval(abs(ivr))) + if (present(ivc)) nmx = max(nmx,maxval(abs(ivc))) + ni = floor(log10(1.0*nmx)) + 1 + + if (datatype=='real') then + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' + else + write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' + end if + write(iout,*) nr, nc, nz + if(present(iv)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j) + end do + enddo + else + if (present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j) + end do + enddo + else if (present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j) + end do + enddo + else if (.not.present(ivr).and..not.present(ivc)) then + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + write(iout,frmtv) (i),(a%ja(j)),a%val(j) + end do + enddo + endif + endif + +end subroutine psb_lz_csr_print + + +subroutine psb_lz_cp_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_from_coo + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + type(psb_lz_coo_sparse_mat) :: tmp + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k,ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='lz_cp_csr_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (.not.b%is_by_rows()) then + ! This is to have fix_coo called behind the scenes + call tmp%cp_from_coo(b,info) + if (info /= psb_success_) return + + nr = tmp%get_nrows() + nc = tmp%get_ncols() + nza = tmp%get_nzeros() + + a%psb_lz_base_sparse_mat = tmp%psb_lz_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(tmp%ia,itemp) + call move_alloc(tmp%ja,a%ja) + call move_alloc(tmp%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call tmp%free() + + else + + if (info /= psb_success_) return + if (b%is_dev()) call b%sync() + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call psb_safe_ab_cpy(b%ia,itemp,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%ja,a%ja,info) + if (info == psb_success_) call psb_safe_ab_cpy(b%val,a%val,info) + if (info == psb_success_) call psb_realloc(max(nr+1,nc+1),a%irp,info) + + endif + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + + +end subroutine psb_lz_cp_csr_from_coo + + + +subroutine psb_lz_cp_csr_to_coo(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_to_coo + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + call b%allocate(nr,nc,nza) + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + b%ja(j) = a%ja(j) + b%val(j) = a%val(j) + end do + end do + call b%set_nzeros(a%get_nzeros()) + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_lz_cp_csr_to_coo + + +subroutine psb_lz_mv_csr_to_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_to_coo + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc,i,j,k,irw + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + if (a%is_dev()) call a%sync() + nr = a%get_nrows() + nc = a%get_ncols() + nza = a%get_nzeros() + + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call b%set_nzeros(a%get_nzeros()) + call move_alloc(a%ja,b%ja) + call move_alloc(a%val,b%val) + call psb_realloc(nza,b%ia,info) + if (info /= psb_success_) return + do i=1, nr + do j=a%irp(i),a%irp(i+1)-1 + b%ia(j) = i + end do + end do + call a%free() + call b%set_sort_status(psb_row_major_) + call b%set_asb() + call b%set_host() + +end subroutine psb_lz_mv_csr_to_coo + + + +subroutine psb_lz_mv_csr_from_coo(a,b,info) + use psb_const_mod + use psb_realloc_mod + use psb_error_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_from_coo + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_coo_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_lpk_), allocatable :: itemp(:) + !locals + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, nc, i,j,k, ip,irw, ncl + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name='mv_from_coo' + + info = psb_success_ + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + if (b%is_dev()) call b%sync() + + if (.not.b%is_by_rows()) call b%fix(info) + if (info /= psb_success_) return + + nr = b%get_nrows() + nc = b%get_ncols() + nza = b%get_nzeros() + + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + + ! Dirty trick: call move_alloc to have the new data allocated just once. + call move_alloc(b%ia,itemp) + call move_alloc(b%ja,a%ja) + call move_alloc(b%val,a%val) + call psb_realloc(max(nr+1,nc+1),a%irp,info) + call b%free() + + + a%irp(:) = 0 + do k=1,nza + i = itemp(k) + a%irp(i) = a%irp(i) + 1 + end do + ip = 1 + do i=1,nr + ncl = a%irp(i) + a%irp(i) = ip + ip = ip + ncl + end do + a%irp(nr+1) = ip + call a%set_host() + +end subroutine psb_lz_mv_csr_from_coo + + +subroutine psb_lz_mv_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_to_fmt + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%mv_to_coo(b,info) + ! Need to fix trivial copies! + type is (psb_lz_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + call move_alloc(a%irp, b%irp) + call move_alloc(a%ja, b%ja) + call move_alloc(a%val, b%val) + call a%free() + call b%set_host() + + class default + call a%mv_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lz_mv_csr_to_fmt + + +subroutine psb_lz_cp_csr_to_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_to_fmt + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%cp_to_coo(b,info) + + type is (psb_lz_csr_sparse_mat) + if (a%is_dev()) call a%sync() + b%psb_lz_base_sparse_mat = a%psb_lz_base_sparse_mat + nr = a%get_nrows() + nz = a%get_nzeros() + if (info == 0) call psb_safe_cpy( a%irp(1:nr+1), b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja(1:nz), b%ja , info) + if (info == 0) call psb_safe_cpy( a%val(1:nz), b%val , info) + call b%set_host() + + class default + call a%cp_to_coo(tmp,info) + if (info == psb_success_) call b%mv_from_coo(tmp,info) + end select + +end subroutine psb_lz_cp_csr_to_fmt + + +subroutine psb_lz_mv_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_mv_csr_from_fmt + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nza, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%mv_from_coo(b,info) + + type is (psb_lz_csr_sparse_mat) + if (b%is_dev()) call b%sync() + + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + call move_alloc(b%irp, a%irp) + call move_alloc(b%ja, a%ja) + call move_alloc(b%val, a%val) + call b%free() + call a%set_host() + + class default + call b%mv_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select + +end subroutine psb_lz_mv_csr_from_fmt + + + +subroutine psb_lz_cp_csr_from_fmt(a,b,info) + use psb_const_mod + use psb_z_base_mat_mod + use psb_realloc_mod + use psb_z_csr_mat_mod, psb_protect_name => psb_lz_cp_csr_from_fmt + implicit none + + class(psb_lz_csr_sparse_mat), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_), intent(out) :: info + + !locals + type(psb_lz_coo_sparse_mat) :: tmp + logical :: rwshr_ + integer(psb_lpk_) :: nz, nr, i,j,irw, nc + integer(psb_ipk_), Parameter :: maxtry=8 + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name + + info = psb_success_ + + select type (b) + type is (psb_lz_coo_sparse_mat) + call a%cp_from_coo(b,info) + + type is (psb_lz_csr_sparse_mat) + if (b%is_dev()) call b%sync() + a%psb_lz_base_sparse_mat = b%psb_lz_base_sparse_mat + nr = b%get_nrows() + nz = b%get_nzeros() + if (info == 0) call psb_safe_cpy( b%irp(1:nr+1), a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja(1:nz) , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val(1:nz) , a%val , info) + call a%set_host() + + class default + call b%cp_to_coo(tmp,info) + if (info == psb_success_) call a%mv_from_coo(tmp,info) + end select +end subroutine psb_lz_cp_csr_from_fmt + +subroutine psb_lzcsrspspmm(a,b,c,info) + use psb_z_mat_mod + use psb_serial_mod, psb_protect_name => psb_lzcsrspspmm + + implicit none + + class(psb_lz_csr_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb, nzc, nza, nzb,nzeb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_csrspspmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if (a%is_dev()) call a%sync() + if (b%is_dev()) call b%sync() + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SPSPMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + + nza = a%get_nzeros() + nzb = b%get_nzeros() + nzc = 2*(nza+nzb) + nze = ma*(((nza+ma-1)/ma)*((nzb+mb-1)/mb) ) + nzeb = (((nza+na-1)/na)*((nzb+nb-1)/nb))*nb + ! Estimate number of nonzeros on output. + ! Turns out this is often a large overestimate. + call c%allocate(ma,nb,nzc) + + call csr_spspmm(a,b,c,info) + + call c%set_asb() + call c%set_host() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_spspmm(a,b,c,info) + implicit none + type(psb_lz_csr_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: ma,na,mb,nb + integer(psb_lpk_), allocatable :: irow(:), idxs(:) + complex(psb_dpk_), allocatable :: row(:) + integer(psb_lpk_) :: i,j,k,irw,icl,icf, iret, & + & nzc,nnzre, isz, ipb, irwsz, nrc, nze + complex(psb_dpk_) :: cfb + + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = min(size(c%val),size(c%ja)) + isz = max(ma,na,mb,nb) + call psb_realloc(isz,row,info) + if (info == 0) call psb_realloc(isz,idxs,info) + if (info == 0) call psb_realloc(isz,irow,info) + if (info /= 0) return + row = dzero + irow = 0 + nzc = 1 + do j = 1,ma + c%irp(j) = nzc + nrc = 0 + do k = a%irp(j), a%irp(j+1)-1 + irw = a%ja(k) + cfb = a%val(k) + irwsz = b%irp(irw+1)-b%irp(irw) + do i = b%irp(irw),b%irp(irw+1)-1 + icl = b%ja(i) + if (irow(icl) 0 ) then + if ((nzc+nrc)>nze) then + nze = max(ma*((nzc+j-1)/j),nzc+2*nrc) + call psb_realloc(nze,c%val,info) + if (info == 0) call psb_realloc(nze,c%ja,info) + if (info /= 0) return + end if + + call psb_qsort(idxs(1:nrc)) + do i=1, nrc + irw = idxs(i) + c%ja(nzc) = irw + c%val(nzc) = row(irw) + row(irw) = dzero + nzc = nzc + 1 + end do + end if + end do + + c%irp(ma+1) = nzc + + + end subroutine csr_spspmm + +end subroutine psb_lzcsrspspmm + diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index d45ee93f9..9a80c2ef8 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -37,8 +37,6 @@ ! for actually executing the method. ! ! -! - ! == =================================== @@ -2434,5 +2432,2423 @@ subroutine psb_z_scals(d,a,info) end subroutine psb_z_scals +subroutine psb_z_mv_from_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_mv_from_lb + implicit none + + class(psb_zspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + if (.not.allocated(a%a)) allocate(psb_z_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%mv_from_lfmt(b,info) + +end subroutine psb_z_mv_from_lb + + +subroutine psb_z_cp_from_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cp_from_lb + implicit none + + class(psb_zspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) allocate(psb_z_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%cp_from_lfmt(b,info) + +end subroutine psb_z_cp_from_lb + +subroutine psb_z_mv_to_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_mv_to_lb + implicit none + + class(psb_zspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%mv_to_lfmt(b,info) + call a%free() + end if + +end subroutine psb_z_mv_to_lb + +subroutine psb_z_cp_to_lb(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cp_to_lb + implicit none + class(psb_zspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%cp_to_lfmt(b,info) + end if + +end subroutine psb_z_cp_to_lb + +subroutine psb_z_mv_from_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_mv_from_l + implicit none + class(psb_zspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_z_csr_sparse_mat :: a%a, stat=info) + call a%a%mv_from_lfmt(b%a,info) + else + call a%free() + end if + call b%free() + +end subroutine psb_z_mv_from_l + + +subroutine psb_z_cp_from_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cp_from_l + implicit none + + class(psb_zspmat_type), intent(out) :: a + class(psb_lzspmat_type), intent(in) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_z_csr_sparse_mat :: a%a, stat=info) + call a%a%cp_from_lfmt(b%a,info) + else + call a%free() + end if +end subroutine psb_z_cp_from_l + +subroutine psb_z_mv_to_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_mv_to_l + implicit none + + class(psb_zspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_lz_csr_sparse_mat :: b%a, stat=info) + call a%a%mv_to_lfmt(b%a,info) + else + call b%free() + end if + call a%free() + +end subroutine psb_z_mv_to_l + +subroutine psb_z_cp_to_l(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_z_cp_to_l + implicit none + + class(psb_zspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_lz_csr_sparse_mat :: b%a, stat=info) + call a%a%cp_to_lfmt(b%a,info) + else + call b%free() + end if + +end subroutine psb_z_cp_to_l +! +! +! lz versions +! + + +subroutine psb_lz_set_nrows(m,a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_nrows + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='set_nrows' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_nrows(m) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_nrows + + +subroutine psb_lz_set_ncols(n,a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_ncols + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: n + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call a%a%set_ncols(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_ncols + + + +! +! Valid values for DUPL: +! psb_dupl_ovwrt_ +! psb_dupl_add_ +! psb_dupl_err_ +! + +subroutine psb_lz_set_dupl(n,a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_dupl + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_dupl(n) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_dupl + + +! +! Set the STATE of the internal matrix object +! + +subroutine psb_lz_set_null(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_null + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_null() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_null + + +subroutine psb_lz_set_bld(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_bld + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_bld() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_bld + + +subroutine psb_lz_set_upd(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_upd + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upd() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lz_set_upd + + +subroutine psb_lz_set_asb(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_asb + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_asb() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_asb + + +subroutine psb_lz_set_sorted(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_sorted + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_sorted(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_sorted + + +subroutine psb_lz_set_triangle(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_triangle + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_triangle(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_triangle + + +subroutine psb_lz_set_unit(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_unit + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_unit(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_unit + + +subroutine psb_lz_set_lower(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_lower + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_lower(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_lower + + +subroutine psb_lz_set_upper(a,val) + use psb_z_mat_mod, psb_protect_name => psb_lz_set_upper + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: val + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%set_upper(val) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_set_upper + + + +! == =================================== +! +! +! +! Data management +! +! +! +! +! +! == =================================== + + +subroutine psb_lz_sparse_print(iout,a,iv,head,ivr,ivc) + use psb_z_mat_mod, psb_protect_name => psb_lz_sparse_print + use psb_error_mod + implicit none + + integer(psb_ipk_), intent(in) :: iout + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%print(iout,iv,head,ivr,ivc) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_sparse_print + + +subroutine psb_lz_n_sparse_print(fname,a,iv,head,ivr,ivc) + use psb_z_mat_mod, psb_protect_name => psb_lz_n_sparse_print + use psb_error_mod + implicit none + + character(len=*), intent(in) :: fname + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in), optional :: iv(:) + character(len=*), optional :: head + integer(psb_lpk_), intent(in), optional :: ivr(:), ivc(:) + + integer(psb_ipk_) :: err_act, info, iout + logical :: isopen + character(len=20) :: name='sparse_print' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1 + do + inquire(unit=iout, opened=isopen) + if (.not.isopen) exit + iout = iout + 1 + if (iout > 99) exit + end do + if (iout > 99) then + write(psb_err_unit,*) 'Error: could not find a free unit for I/O' + return + end if + open(iout,file=fname,iostat=info) + if (info == psb_success_) then + call a%a%print(iout,iv,head,ivr,ivc) + close(iout) + else + write(psb_err_unit,*) 'Error: could not open ',fname,' for output' + end if + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_n_sparse_print + + +subroutine psb_lz_get_neigh(a,idx,neigh,n,info,lev) + use psb_z_mat_mod, psb_protect_name => psb_lz_get_neigh + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: idx + integer(psb_lpk_), intent(out) :: n + integer(psb_lpk_), allocatable, intent(out) :: neigh(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), optional, intent(in) :: lev + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_neigh' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_get_neigh + + + +subroutine psb_lz_csall(nr,nc,a,info,nz) + use psb_z_mat_mod, psb_protect_name => psb_lz_csall + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: nr,nc + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: nz + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + call a%free() + + info = psb_success_ + allocate(psb_lz_coo_sparse_mat :: a%a, stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csall + + +subroutine psb_lz_reallocate_nz(nz,a) + use psb_z_mat_mod, psb_protect_name => psb_lz_reallocate_nz + use psb_error_mod + implicit none + integer(psb_lpk_), intent(in) :: nz + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reallocate_nz' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_reallocate_nz + + +subroutine psb_lz_free(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_free + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + endif + +end subroutine psb_lz_free + + +subroutine psb_lz_trim(a) + use psb_z_mat_mod, psb_protect_name => psb_lz_trim + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='trim' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%trim() + + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_trim + + + +subroutine psb_lz_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_mat_mod, psb_protect_name => psb_lz_csput_a + use psb_z_base_mat_mod + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: val(:) + integer(psb_lpk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_a' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csput(nz,ia,ja,val,imin,imax,jmin,jmax,info,gtl) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csput_a + +subroutine psb_lz_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) + use psb_z_mat_mod, psb_protect_name => psb_lz_csput_v + use psb_z_base_mat_mod + use psb_z_vect_mod, only : psb_z_vect_type + use psb_l_vect_mod, only : psb_l_vect_type + use psb_error_mod + implicit none + class(psb_lzspmat_type), intent(inout) :: a + type(psb_z_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: ia, ja + integer(psb_lpk_), intent(in) :: nz, imin,imax,jmin,jmax + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in), optional :: gtl(:) + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csput_v' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.(a%is_bld().or.a%is_upd())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then + call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl) + else + info = psb_err_invalid_mat_state_ + endif + + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csput_v + + +subroutine psb_lz_csgetptn(imin,imax,a,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_csgetptn + implicit none + + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csgetptn + + +subroutine psb_lz_csgetrow(imin,imax,a,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_csgetrow + implicit none + + class(psb_lzspmat_type), intent(in) :: a + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_lpk_), intent(out) :: nz + integer(psb_lpk_), allocatable, intent(inout) :: ia(:), ja(:) + complex(psb_dpk_), allocatable, intent(inout) :: val(:) + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax, nzin + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call a%a%csget(imin,imax,nz,ia,ja,val,info,& + & jmin,jmax,iren,append,nzin,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csgetrow + + + + +subroutine psb_lz_csgetblk(imin,imax,a,b,info,& + & jmin,jmax,iren,append,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_csgetblk + implicit none + + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_lpk_), intent(in) :: imin,imax + integer(psb_ipk_),intent(out) :: info + logical, intent(in), optional :: append + integer(psb_lpk_), intent(in), optional :: iren(:) + integer(psb_lpk_), intent(in), optional :: jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csget' + logical, parameter :: debug=.false. + logical :: append_ + type(psb_lz_coo_sparse_mat), allocatable :: acoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(append)) then + append_ = append + else + append_ = .false. + end if + + allocate(acoo,stat=info) + if (append_.and.(info==psb_success_)) then + if (allocated(b%a)) & + & call b%a%mv_to_coo(acoo,info) + end if + + if (info == psb_success_) then + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csgetblk + + +subroutine psb_lz_tril(a,l,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,u) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_tril + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: l + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lzspmat_type), optional, intent(inout) :: u + + integer(psb_ipk_) :: err_act + character(len=20) :: name='tril' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat), allocatable :: lcoo, ucoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(lcoo,stat=info) + call l%free() + if (present(u)) then + if (info == psb_success_) allocate(ucoo,stat=info) + call u%free() + if (info == psb_success_) call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,ucoo) + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%tril(lcoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lz_tril + +subroutine psb_lz_triu(a,u,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,l) + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_triu + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: u + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: diag,imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + class(psb_lzspmat_type), optional, intent(inout) :: l + + integer(psb_ipk_) :: err_act + character(len=20) :: name='triu' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat), allocatable :: lcoo, ucoo + + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ucoo,stat=info) + call u%free() + + if (present(l)) then + if (info == psb_success_) allocate(lcoo,stat=info) + call l%free() + if (info == psb_success_) call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale,lcoo) + if (info == psb_success_) call move_alloc(lcoo,l%a) + if (info == psb_success_) call l%cscnv(info,mold=a%a) + else + if (info == psb_success_) then + call a%a%triu(ucoo,info,diag,imin,imax,& + & jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + end if + if (info == psb_success_) call move_alloc(ucoo,u%a) + if (info == psb_success_) call u%cscnv(info,mold=a%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + + +end subroutine psb_lz_triu + + +subroutine psb_lz_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_csclip + implicit none + + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + type(psb_lz_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(acoo,stat=info) + call b%free() + if (info == psb_success_) then + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_csclip + + +subroutine psb_lz_b_csclip(a,b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + ! Output is always in COO format + use psb_error_mod + use psb_const_mod + use psb_z_base_mat_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_b_csclip + implicit none + + class(psb_lzspmat_type), intent(in) :: a + type(psb_lz_coo_sparse_mat), intent(out) :: b + integer(psb_ipk_),intent(out) :: info + integer(psb_lpk_), intent(in), optional :: imin,imax,jmin,jmax + logical, intent(in), optional :: rscale,cscale + + integer(psb_ipk_) :: err_act + character(len=20) :: name='csclip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%csclip(b,info,& + & imin,imax,jmin,jmax,rscale,cscale) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_b_csclip + + + + +subroutine psb_lz_cscnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cscnv + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psb_lz_base_sparse_mat), intent(in), optional :: mold + + + class(psb_lz_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_lz_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_lz_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_lz_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + + if (present(dupl)) then + call altmp%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call altmp%set_dupl(psb_dupl_def_) + end if + + if (debug) write(psb_err_unit,*) 'Converting from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%cp_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%trim() + call b%asb() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cscnv + + + +subroutine psb_lz_cscnv_ip(a,info,type,mold,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cscnv_ip + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psb_lz_base_sparse_mat), intent(in), optional :: mold + + + class(psb_lz_base_sparse_mat), allocatable :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv_ip' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psb_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = psb_err_many_optional_arg_ + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, mold=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psb_lz_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psb_lz_coo_sparse_mat :: altmp, stat=info) + case ('CSC') + allocate(psb_lz_csc_sparse_mat :: altmp, stat=info) + case default + info = psb_err_format_unknown_ + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(altmp, mold=psb_get_mat_default(a),stat=info) + end if + + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + if (debug) write(psb_err_unit,*) 'Converting in-place from ',& + & a%get_fmt(),' to ',altmp%get_fmt() + + call altmp%mv_from_fmt(a%a, info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() + call a%trim() + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cscnv_ip + + + +subroutine psb_lz_cscnv_base(a,b,info,dupl) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cscnv_base + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(out) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_),optional, intent(in) :: dupl + + + type(psb_lz_coo_sparse_mat) :: altmp + integer(psb_ipk_) :: err_act + character(len=20) :: name='cscnv' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%cp_to_coo(altmp,info ) + if ((info == psb_success_).and.present(dupl)) then + call altmp%set_dupl(dupl) + end if + call altmp%fix(info) + if (info == psb_success_) call altmp%trim() + if (info == psb_success_) call altmp%set_asb() + if (info == psb_success_) call b%mv_from_coo(altmp,info) + + if (info /= psb_success_) then + info = psb_err_from_subroutine_ + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_cscnv_base + + + +!!$subroutine psb_lz_clip_d(a,b,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_z_base_mat_mod +!!$ use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d +!!$ implicit none +!!$ +!!$ class(psb_lzspmat_type), intent(in) :: a +!!$ class(psb_lzspmat_type), intent(inout) :: b +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_lz_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%cp_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call b%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_lz_clip_d +!!$ +!!$ +!!$ +!!$subroutine psb_lz_clip_d_ip(a,info) +!!$ ! Output is always in COO format +!!$ use psb_error_mod +!!$ use psb_const_mod +!!$ use psb_z_base_mat_mod +!!$ use psb_z_mat_mod, psb_protect_name => psb_lz_clip_d_ip +!!$ implicit none +!!$ +!!$ class(psb_lzspmat_type), intent(inout) :: a +!!$ integer(psb_ipk_),intent(out) :: info +!!$ +!!$ integer(psb_ipk_) :: err_act +!!$ character(len=20) :: name='clip_diag' +!!$ logical, parameter :: debug=.false. +!!$ type(psb_lz_coo_sparse_mat), allocatable :: acoo +!!$ integer(psb_lpk_) :: i, j, nz +!!$ +!!$ info = psb_success_ +!!$ call psb_erractionsave(err_act) +!!$ if (a%is_null()) then +!!$ info = psb_err_invalid_mat_state_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ allocate(acoo,stat=info) +!!$ if (info == psb_success_) call a%a%mv_to_coo(acoo,info) +!!$ if (info /= psb_success_) then +!!$ info = psb_err_alloc_dealloc_ +!!$ call psb_errpush(info,name) +!!$ goto 9999 +!!$ endif +!!$ +!!$ nz = acoo%get_nzeros() +!!$ j = 0 +!!$ do i=1, nz +!!$ if (acoo%ia(i) /= acoo%ja(i)) then +!!$ j = j + 1 +!!$ acoo%ia(j) = acoo%ia(i) +!!$ acoo%ja(j) = acoo%ja(i) +!!$ acoo%val(j) = acoo%val(i) +!!$ end if +!!$ end do +!!$ call acoo%set_nzeros(j) +!!$ call acoo%trim() +!!$ call a%mv_from(acoo) +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$ +!!$9999 call psb_error_handler(err_act) +!!$ +!!$ return +!!$ +!!$end subroutine psb_lz_clip_d_ip +!!$ + +subroutine psb_lz_mv_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_mv_from + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call a%free() + allocate(a%a,mold=b, stat=info) + call a%a%mv_from_fmt(b,info) + call b%free() + + return +end subroutine psb_lz_mv_from + + +subroutine psb_lz_cp_from(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cp_from + implicit none + class(psb_lzspmat_type), intent(out) :: a + class(psb_lz_base_sparse_mat), intent(in) :: b + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='cp_from' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + + call a%free() + ! + ! Note: it is tempting to use SOURCE allocation below; + ! however this would run the risk of messing up with data + ! allocated externally (e.g. GPU-side data). + ! + allocate(a%a,mold=b,stat=info) + if (info /= psb_success_) info = psb_err_alloc_dealloc_ + if (info == psb_success_) call a%a%cp_from_fmt(b, info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lz_cp_from + + +subroutine psb_lz_mv_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_mv_to + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%mv_from_fmt(a%a,info) + + return +end subroutine psb_lz_mv_to + + +subroutine psb_lz_cp_to(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cp_to + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lz_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + call b%cp_from_fmt(a%a,info) + + return +end subroutine psb_lz_cp_to + +subroutine psb_lz_mold(a,b) + use psb_z_mat_mod, psb_protect_name => psb_lz_mold + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), allocatable, intent(out) :: b + integer(psb_ipk_) :: info + + allocate(b,mold=a%a, stat=info) + +end subroutine psb_lz_mold + +subroutine psb_lzspmat_type_move(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lzspmat_type_move + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='move_alloc' + logical, parameter :: debug=.false. + + info = psb_success_ + call b%free() + call move_alloc(a%a,b%a) + + return +end subroutine psb_lzspmat_type_move + + +subroutine psb_lzspmat_clone(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lzspmat_clone + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lzspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='clone' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lzspmat_clone + + +subroutine psb_lz_transp_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_transp_1mat + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_transp_1mat + + + +subroutine psb_lz_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_transp_2mat + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transp(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_transp_2mat + + +subroutine psb_lz_transc_1mat(a) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_transc_1mat + implicit none + class(psb_lzspmat_type), intent(inout) :: a + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_transc_1mat + + + +subroutine psb_lz_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_transc_2mat + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_lzspmat_type), intent(inout) :: b + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + call b%free() + allocate(b%a,mold=a%a,stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + goto 9999 + end if + call a%a%transc(b%a) + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_transc_2mat + + +subroutine psb_lz_asb(a,mold) + use psb_z_mat_mod, psb_protect_name => psb_lz_asb + use psb_error_mod + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + class(psb_lz_base_sparse_mat), optional, intent(in) :: mold + class(psb_lz_base_sparse_mat), allocatable :: tmp + class(psb_lz_base_sparse_mat), pointer :: mld + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='lz_asb' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%asb() + if (present(mold)) then + if (.not.same_type_as(a%a,mold)) then + allocate(tmp,mold=mold) + call tmp%mv_from_fmt(a%a,info) + call a%a%free() + call move_alloc(tmp,a%a) + end if + else + mld => psb_lz_get_base_mat_default() + if (.not.same_type_as(a%a,mld)) & + & call a%cscnv(info) + end if + + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_asb + +subroutine psb_lz_reinit(a,clear) + use psb_z_mat_mod, psb_protect_name => psb_lz_reinit + use psb_error_mod + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + logical, intent(in), optional :: clear + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='reinit' + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + if (a%a%has_update()) then + call a%a%reinit(clear) + else + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_reinit + + + + +function psb_lz_get_diag(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_get_diag + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='get_diag' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,min(a%a%get_nrows(),a%a%get_ncols()))), stat=info) + if (info /= 0) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + call a%a%get_diag(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_get_diag + + +subroutine psb_lz_scal(d,a,info,side) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_scal + implicit none + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d(:) + integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: side + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info,side=side) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_scal + + +subroutine psb_lz_scals(d,a,info) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_scals + implicit none + class(psb_lzspmat_type), intent(inout) :: a + complex(psb_dpk_), intent(in) :: d + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%scal(d,info) + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lz_scals + +function psb_lz_maxval(a) result(res) + use psb_z_mat_mod, psb_protect_name => psb_lz_maxval + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='maxval' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%maxval() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_maxval + +function psb_lz_csnmi(a) result(res) + use psb_z_mat_mod, psb_protect_name => psb_lz_csnmi + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + + info = psb_success_ + call psb_get_erraction(err_act) + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnmi() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_csnmi + +function psb_lz_csnm1(a) result(res) + use psb_z_mat_mod, psb_protect_name => psb_lz_csnm1 + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_) :: res + + integer(psb_ipk_) :: err_act, info + character(len=20) :: name='csnm1' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%spnm1() + return + + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_csnm1 + + +function psb_lz_rowsum(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_rowsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='rowsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + call a%a%rowsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_rowsum + +function psb_lz_arwsum(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_arwsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='arwsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_nrows())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%arwsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_arwsum + +function psb_lz_colsum(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_colsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + complex(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='colsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%colsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_colsum + +function psb_lz_aclsum(a,info) result(d) + use psb_z_mat_mod, psb_protect_name => psb_lz_aclsum + use psb_error_mod + use psb_const_mod + implicit none + class(psb_lzspmat_type), intent(in) :: a + real(psb_dpk_), allocatable :: d(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='aclsum' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + if (.not.allocated(a%a)) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(d(max(1,a%a%get_ncols())), stat=info) + if (info /= psb_success_) goto 9999 + + call a%a%aclsum(d) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end function psb_lz_aclsum + +subroutine psb_lz_mv_from_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_mv_from_ib + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + if (.not.allocated(a%a)) allocate(psb_lz_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%mv_from_ifmt(b,info) + +end subroutine psb_lz_mv_from_ib + +subroutine psb_lz_cp_from_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cp_from_ib + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) allocate(psb_lz_csr_sparse_mat :: a%a, stat=info) + if (info == psb_success_) call a%a%cp_from_ifmt(b,info) + +end subroutine psb_lz_cp_from_ib + +subroutine psb_lz_mv_to_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_mv_to_ib + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%mv_to_ifmt(b,info) + call a%free() + end if + +end subroutine psb_lz_mv_to_ib + +subroutine psb_lz_cp_to_ib(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cp_to_ib + implicit none + class(psb_lzspmat_type), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_) :: info + + if (.not.allocated(a%a)) then + call b%free() + else + call a%a%cp_to_ifmt(b,info) + end if + +end subroutine psb_lz_cp_to_ib + +subroutine psb_lz_mv_from_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_mv_from_i + implicit none + class(psb_lzspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_lz_csr_sparse_mat :: a%a, stat=info) + call a%a%mv_from_ifmt(b%a,info) + else + call a%free() + end if + call b%free() + +end subroutine psb_lz_mv_from_i + + +subroutine psb_lz_cp_from_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cp_from_i + implicit none + + class(psb_lzspmat_type), intent(out) :: a + class(psb_zspmat_type), intent(in) :: b + integer(psb_ipk_) :: info + + if (allocated(b%a)) then + if (.not.allocated(a%a)) allocate(psb_lz_csr_sparse_mat :: a%a, stat=info) + call a%a%cp_from_ifmt(b%a,info) + else + call a%free() + end if +end subroutine psb_lz_cp_from_i + +subroutine psb_lz_mv_to_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_mv_to_i + implicit none + + class(psb_lzspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_z_csr_sparse_mat :: b%a, stat=info) + call a%a%mv_to_ifmt(b%a,info) + else + call b%free() + end if + call a%free() + +end subroutine psb_lz_mv_to_i + +subroutine psb_lz_cp_to_i(a,b) + use psb_error_mod + use psb_const_mod + use psb_z_mat_mod, psb_protect_name => psb_lz_cp_to_i + implicit none + + class(psb_lzspmat_type), intent(in) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_) :: info + + if (allocated(a%a)) then + if (.not.allocated(b%a)) allocate(psb_z_csr_sparse_mat :: b%a, stat=info) + call a%a%cp_to_ifmt(b%a,info) + else + call b%free() + end if + +end subroutine psb_lz_cp_to_i + + + + diff --git a/base/serial/lsmmp.f90 b/base/serial/lsmmp.f90 new file mode 100644 index 000000000..2bf2efdaa --- /dev/null +++ b/base/serial/lsmmp.f90 @@ -0,0 +1,478 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Original code adapted from: +! == ===================================================================== +! Sparse Matrix Multiplication Package +! +! Randolph E. Bank and Craig C. Douglas +! +! na.bank@na-net.ornl.gov and na.cdouglas@na-net.ornl.gov +! +! Compile this with the following command (or a similar one): +! +! f77 -c -O smmp.f +! +! == ===================================================================== +subroutine lsymbmm(n, m, l, ia, ja, diaga, ib, jb, diagb,& + & ic, jc, diagc, index) + use psb_const_mod + use psb_realloc_mod + use psb_sort_mod, only: psb_msort + ! + integer(psb_lpk_) :: ia(*), ja(*), diaga, & + & ib(*), jb(*), diagb, diagc, index(*) + integer(psb_lpk_), allocatable :: ic(:),jc(:) + integer(psb_lpk_) :: nze + integer(psb_ipk_) :: info + + ! + ! symbolic matrix multiply c=a*b + ! + if (size(ic) < n+1) then + write(psb_err_unit,*)& + & 'Called realloc in SYMBMM ' + call psb_realloc(n+1,ic,info) + if (info /= psb_success_) then + write(psb_err_unit,*)& + & 'realloc failed in SYMBMM ',info + end if + endif + maxlmn = max(l,m,n) + do i=1,maxlmn + index(i)=0 + end do + if (diagc.eq.0) then + ic(1)=1 + else + ic(1)=n+2 + endif + minlm = min(l,m) + minmn = min(m,n) + ! + ! main loop + ! + do i=1,n + istart=-1 + length=0 + ! + ! merge row lists + ! + rowi: do jj=ia(i),ia(i+1) + ! a = d + ... + if (jj.eq.ia(i+1)) then + if (diaga.eq.0 .or. i.gt.minmn) cycle rowi + j = i + else + j=ja(jj) + endif + ! b = d + ... + if (index(j).eq.0 .and. diagb.eq.1 .and. j.le.minlm)then + index(j)=istart + istart=j + length=length+1 + endif + if ((j<1).or.(j>m)) then + write(psb_err_unit,*)& + & ' SymbMM: Problem with A ',i,jj,j,m + endif + do k=ib(j),ib(j+1)-1 + if ((jb(k)<1).or.(jb(k)>maxlmn)) then + write(psb_err_unit,*)& + & 'Problem in SYMBMM 1:',j,k,jb(k),maxlmn + else + if(index(jb(k)).eq.0) then + index(jb(k))=istart + istart=jb(k) + length=length+1 + endif + endif + end do + end do rowi + + ! + ! row i of jc + ! + if (diagc.eq.1 .and. index(i).ne.0) length = length - 1 + ic(i+1)=ic(i)+length + + if (ic(i+1) > size(jc)) then + if (n > (2*i)) then + nze = max(ic(i+1), ic(i)*((n+i-1)/i)) + else + nze = max(ic(i+1), nint((dble(ic(i))*(dble(n)/i))) ) + endif + call psb_realloc(nze,jc,info) + end if + + do j= ic(i),ic(i+1)-1 + if (diagc.eq.1 .and. istart.eq.i) then + istart = index(istart) + index(i) = 0 + endif + jc(j)=istart + istart=index(istart) + index(jc(j))=0 + end do + call psb_msort(jc(ic(i):ic(i)+length -1)) + index(i) = 0 + end do + return +end subroutine lsymbmm +! == ===================================================================== +! Sparse Matrix Multiplication Package +! +! Randolph E. Bank and Craig C. Douglas +! +! na.bank@na-net.ornl.gov and na.cdouglas@na-net.ornl.gov +! +! Compile this with the following command (or a similar one): +! +! f77 -c -O smmp.f +! +! == ===================================================================== +subroutine lcnumbmm(n, m, l, ia, ja, diaga, a, ib, jb, diagb, b,& + & ic, jc, diagc, c, temp) + ! + use psb_const_mod + integer(psb_lpk_) :: ia(*), ja(*), diaga,& + & ib(*), jb(*), diagb, ic(*), jc(*), diagc + ! + complex(psb_spk_) :: a(*), b(*), c(*), temp(*),ajj + ! + ! numeric matrix multiply c=a*b + ! + maxlmn = max(l,m,n) + do i = 1,maxlmn + temp(i) = 0. + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + ! + ! c = a*b + ! + do i = 1,n + rowi: do jj = ia(i),ia(i+1) + ! a = d + ... + if (jj.eq.ia(i+1)) then + if (diaga.eq.0 .or. i.gt.minmn) cycle rowi + j = i + ajj = a(i) + else + j=ja(jj) + ajj = a(jj) + endif + ! b = d + ... + if (diagb.eq.1 .and. j.le.minlm) & + & temp(j) = temp(j) + ajj * b(j) + if ((j<1).or.(j>m)) then + write(psb_err_unit,*)& + & ' NUMBMM: Problem with A ',i,jj,j,m + endif + + do k = ib(j),ib(j+1)-1 + if((jb(k)<1).or. (jb(k) > maxlmn)) then + write(psb_err_unit,*)& + & ' NUMBMM: jb problem',j,k,jb(k),maxlmn + else + temp(jb(k)) = temp(jb(k)) + ajj * b(k) + endif + end do + end do rowi + + ! c = d + ... + if (diagc.eq.1 .and. i.le.minln) then + c(i) = temp(i) + temp(i) = 0. + endif + !$$$ if (mod(i,100) == 1) + !$$$ + write(psb_err_unit,*) + !$$$ ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 + do j = ic(i),ic(i+1)-1 + if((jc(j)<1).or. (jc(j) > maxlmn)) then + write(psb_err_unit,*)& + & ' NUMBMM: output problem',i,j,jc(j),maxlmn + else + c(j) = temp(jc(j)) + temp(jc(j)) = 0. + endif + end do + end do + + return +end subroutine lcnumbmm +! == ===================================================================== +! Sparse Matrix Multiplication Package +! +! Randolph E. Bank and Craig C. Douglas +! +! na.bank@na-net.ornl.gov and na.cdouglas@na-net.ornl.gov +! +! Compile this with the following command (or a similar one): +! +! f77 -c -O smmp.f +! +! == ===================================================================== +subroutine ldnumbmm(n, m, l, ia, ja, diaga, a, ib, jb, diagb, b,& + & ic, jc, diagc, c, temp) + use psb_const_mod + ! + integer(psb_lpk_) :: ia(*), ja(*), diaga, ib(*), jb(*), diagb,& + & ic(*), jc(*), diagc + ! + real(psb_dpk_) :: a(*), b(*), c(*), temp(*),ajj + ! + ! numeric matrix multiply c=a*b + ! + maxlmn = max(l,m,n) + do i = 1,maxlmn + temp(i) = 0. + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + ! + ! c = a*b + ! + do i = 1,n + rowi: do jj = ia(i),ia(i+1) + ! a = d + ... + if (jj.eq.ia(i+1)) then + if (diaga.eq.0 .or. i.gt.minmn) cycle rowi + j = i + ajj = a(i) + else + j=ja(jj) + ajj = a(jj) + endif + ! b = d + ... + if (diagb.eq.1 .and. j.le.minlm) & + & temp(j) = temp(j) + ajj * b(j) + if ((j<1).or.(j>m)) then + write(psb_err_unit,*)& + & ' NUMBMM: Problem with A ',i,jj,j,m + endif + + do k = ib(j),ib(j+1)-1 + if((jb(k)<1).or. (jb(k) > maxlmn)) then + write(psb_err_unit,*)& + & ' NUMBMM: jb problem',j,k,jb(k),maxlmn + else + temp(jb(k)) = temp(jb(k)) + ajj * b(k) + endif + end do + end do rowi + + ! c = d + ... + if (diagc.eq.1 .and. i.le.minln) then + c(i) = temp(i) + temp(i) = 0. + endif + !$$$ if (mod(i,100) == 1) + !$$$ + write(psb_err_unit,*) + !$$$ ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 + do j = ic(i),ic(i+1)-1 + if((jc(j)<1).or. (jc(j) > maxlmn)) then + write(psb_err_unit,*)& + & ' NUMBMM: output problem',i,j,jc(j),maxlmn + else + c(j) = temp(jc(j)) + temp(jc(j)) = 0. + endif + end do + end do + + return +end subroutine ldnumbmm +! == ===================================================================== +! Sparse Matrix Multiplication Package +! +! Randolph E. Bank and Craig C. Douglas +! +! na.bank@na-net.ornl.gov and na.cdouglas@na-net.ornl.gov +! +! Compile this with the following command (or a similar one): +! +! f77 -c -O smmp.f +! +! == ===================================================================== +subroutine lsnumbmm(n, m, l, ia, ja, diaga, a, ib, jb, diagb, b,& + & ic, jc, diagc, c, temp) + use psb_const_mod + ! + integer(psb_lpk_) :: ia(*), ja(*), diaga, ib(*), jb(*), diagb,& + & ic(*), jc(*), diagc + ! + real(psb_spk_) :: a(*), b(*), c(*), temp(*),ajj + ! + ! numeric matrix multiply c=a*b + ! + maxlmn = max(l,m,n) + do i = 1,maxlmn + temp(i) = 0. + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + ! + ! c = a*b + ! + do i = 1,n + rowi: do jj = ia(i),ia(i+1) + ! a = d + ... + if (jj.eq.ia(i+1)) then + if (diaga.eq.0 .or. i.gt.minmn) cycle rowi + j = i + ajj = a(i) + else + j=ja(jj) + ajj = a(jj) + endif + ! b = d + ... + if (diagb.eq.1 .and. j.le.minlm) & + & temp(j) = temp(j) + ajj * b(j) + if ((j<1).or.(j>m)) then + write(psb_err_unit,*)& + & ' NUMBMM: Problem with A ',i,jj,j,m + endif + + do k = ib(j),ib(j+1)-1 + if((jb(k)<1).or. (jb(k) > maxlmn)) then + write(psb_err_unit,*)& + & ' NUMBMM: jb problem',j,k,jb(k),maxlmn + else + temp(jb(k)) = temp(jb(k)) + ajj * b(k) + endif + end do + end do rowi + + ! c = d + ... + if (diagc.eq.1 .and. i.le.minln) then + c(i) = temp(i) + temp(i) = 0. + endif + !$$$ if (mod(i,100) == 1) + !$$$ + write(psb_err_unit,*) + !$$$ ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 + do j = ic(i),ic(i+1)-1 + if((jc(j)<1).or. (jc(j) > maxlmn)) then + write(psb_err_unit,*)& + & ' NUMBMM: output problem',i,j,jc(j),maxlmn + else + c(j) = temp(jc(j)) + temp(jc(j)) = 0. + endif + end do + end do + + return +end subroutine lsnumbmm +! == ===================================================================== +! Sparse Matrix Multiplication Package +! +! Randolph E. Bank and Craig C. Douglas +! +! na.bank@na-net.ornl.gov and na.cdouglas@na-net.ornl.gov +! +! Compile this with the following command (or a similar one): +! +! f77 -c -O smmp.f +! +! == ===================================================================== +subroutine lznumbmm(n, m, l, ia, ja, diaga, a, ib, jb, diagb, b,& + & ic, jc, diagc, c, temp) + ! + use psb_const_mod + integer(psb_lpk_) :: ia(*), ja(*), diaga, ib(*), jb(*), diagb,& + & ic(*), jc(*), diagc + ! + complex(psb_dpk_) :: a(*), b(*), c(*), temp(*),ajj + ! + ! numeric matrix multiply c=a*b + ! + maxlmn = max(l,m,n) + do i = 1,maxlmn + temp(i) = 0. + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + ! + ! c = a*b + ! + do i = 1,n + rowi: do jj = ia(i),ia(i+1) + ! a = d + ... + if (jj.eq.ia(i+1)) then + if (diaga.eq.0 .or. i.gt.minmn) cycle rowi + j = i + ajj = a(i) + else + j=ja(jj) + ajj = a(jj) + endif + ! b = d + ... + if (diagb.eq.1 .and. j.le.minlm) & + & temp(j) = temp(j) + ajj * b(j) + if ((j<1).or.(j>m)) then + write(psb_err_unit,*)& + & ' NUMBMM: Problem with A ',i,jj,j,m + endif + + do k = ib(j),ib(j+1)-1 + if((jb(k)<1).or. (jb(k) > maxlmn)) then + write(psb_err_unit,*)& + & ' NUMBMM: jb problem',j,k,jb(k),maxlmn + else + temp(jb(k)) = temp(jb(k)) + ajj * b(k) + endif + end do + end do rowi + + ! c = d + ... + if (diagc.eq.1 .and. i.le.minln) then + c(i) = temp(i) + temp(i) = 0. + endif + do j = ic(i),ic(i+1)-1 + if((jc(j)<1).or. (jc(j) > maxlmn)) then + write(psb_err_unit,*)& + & ' NUMBMM: output problem',i,j,jc(j),maxlmn + else + c(j) = temp(jc(j)) + temp(jc(j)) = 0. + endif + end do + end do + + return +end subroutine lznumbmm diff --git a/base/serial/psb_cnumbmm.f90 b/base/serial/psb_cnumbmm.f90 index 94e6e1a5a..c965d4f3a 100644 --- a/base/serial/psb_cnumbmm.f90 +++ b/base/serial/psb_cnumbmm.f90 @@ -39,7 +39,6 @@ ! rewritten in Fortran 95/2003 making use of our sparse matrix facilities. ! ! - subroutine psb_cnumbmm(a,b,c) use psb_base_mod, psb_protect_name => psb_cnumbmm implicit none @@ -234,3 +233,200 @@ contains end subroutine gen_numbmm end subroutine psb_cbase_numbmm + + + +subroutine psb_lcnumbmm(a,b,c) + use psb_base_mod, psb_protect_name => psb_lcnumbmm + implicit none + + type(psb_lcspmat_type), intent(in) :: a,b + type(psb_lcspmat_type), intent(inout) :: c + integer(psb_ipk_) :: info + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_numbmm' + + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null()).or.(c%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + select type(aa=>c%a) + type is (psb_lc_csr_sparse_mat) + call psb_numbmm(a%a,b%a,aa) + class default + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end select + + call c%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lcnumbmm + +subroutine psb_lcbase_numbmm(a,b,c) + use psb_mat_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_lcbase_numbmm + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_lpk_) :: nze, ma,na,mb,nb + character(len=20) :: name + complex(psb_spk_), allocatable :: temp(:) + integer(psb_ipk_) :: info + integer(psb_ipk_) :: err_act + name='psb_numbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb + endif + allocate(temp(max(ma,na,mb,nb)),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + endif + + ! + ! Note: we still have to test about possible performance hits. + ! + ! + call psb_ensure_size(ione*size(c%ja),c%val,info) + select type(a) + type is (psb_lc_csr_sparse_mat) + select type(b) + type is (psb_lc_csr_sparse_mat) + call csr_numbmm(a,b,c,temp,info) + class default + call gen_numbmm(a,b,c,temp,info) + end select + class default + call gen_numbmm(a,b,c,temp,info) + end select + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call c%set_asb() + deallocate(temp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_numbmm(a,b,c,temp,info) + type(psb_lc_csr_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(inout) :: c + complex(psb_spk_) :: temp(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + call lcnumbmm(ma,na,nb,a%irp,a%ja,lzero,a%val,& + & b%irp,b%ja,lzero,b%val,& + & c%irp,c%ja,lzero,c%val,temp) + + + end subroutine csr_numbmm + + subroutine gen_numbmm(a,b,c,temp,info) + class(psb_lc_base_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_) :: info + complex(psb_spk_) :: temp(:) + integer(psb_lpk_), allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + complex(psb_spk_), allocatable :: aval(:),bval(:) + integer(psb_lpk_) :: maxlmn,i,j,m,n,k,l,nazr,nbzr,jj,minlm,minmn,minln + complex(psb_spk_) :: ajj + + n = a%get_nrows() + m = a%get_ncols() + l = b%get_ncols() + maxlmn = max(l,m,n) + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & aval(maxlmn),bval(maxlmn), stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + return + endif + + do i = 1,maxlmn + temp(i) = czero + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + do i = 1,n + + call a%csget(i,i,nazr,iarw,iacl,aval,info) + do jj=1, nazr + j=iacl(jj) + ajj = aval(jj) + if ((j<1).or.(j>m)) then + write(psb_err_unit,*) ' NUMBMM: Problem with A ',i,jj,j,m + info = 1 + return + + endif + call b%csget(j,j,nbzr,ibrw,ibcl,bval,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(psb_err_unit,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn + info = psb_err_pivot_too_small_ + return + else + temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) + endif + enddo + end do + do j = c%irp(i),c%irp(i+1)-1 + if((c%ja(j)<1).or. (c%ja(j) > maxlmn)) then + write(psb_err_unit,*) ' NUMBMM: output problem',i,j,c%ja(j),maxlmn + info = psb_err_invalid_ovr_num_ + return + else + c%val(j) = temp(c%ja(j)) + temp(c%ja(j)) = czero + endif + end do + end do + + + end subroutine gen_numbmm + +end subroutine psb_lcbase_numbmm diff --git a/base/serial/psb_crwextd.f90 b/base/serial/psb_crwextd.f90 index e19af57af..d801428a0 100644 --- a/base/serial/psb_crwextd.f90 +++ b/base/serial/psb_crwextd.f90 @@ -35,17 +35,18 @@ ! ! We have a problem here: 1. How to handle well all the formats? ! 2. What should we do with rowscale? Does it only -! apply when a%fida='COO' ?????? +! apply when a%fmt()='COO' ?????? ! ! subroutine psb_crwextd(nr,a,info,b,rowscale) - use psb_base_mod, psb_protect_name => psb_crwextd + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_crwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr type(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info type(psb_cspmat_type), intent(in), optional :: b logical,intent(in), optional :: rowscale @@ -89,23 +90,20 @@ subroutine psb_crwextd(nr,a,info,b,rowscale) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if +9999 call psb_error_handler(err_act) + return end subroutine psb_crwextd subroutine psb_cbase_rwextd(nr,a,info,b,rowscale) - use psb_base_mod, psb_protect_name => psb_cbase_rwextd + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_cbase_rwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr class(psb_c_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: b logical,intent(in), optional :: rowscale @@ -236,12 +234,213 @@ subroutine psb_cbase_rwextd(nr,a,info,b,rowscale) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if +9999 call psb_error_handler(err_act) + return end subroutine psb_cbase_rwextd + + +subroutine psb_lcrwextd(nr,a,info,b,rowscale) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lcrwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer(psb_lpk_), intent(in) :: nr + type(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + type(psb_lcspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer(psb_lpk_) :: i,j,ja,jb,nza,nzb + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + type(psb_lc_coo_sparse_mat) :: actmp + logical rowscale_ + + name='psb_lcrwextd' + info = psb_success_ + call psb_erractionsave(err_act) + + if (nr > a%get_nrows()) then + select type(aa=> a%a) + type is (psb_lc_csr_sparse_mat) + if (present(b)) then + call psb_rwextd(nr,aa,info,b%a,rowscale) + else + call psb_rwextd(nr,aa,info,rowscale=rowscale) + end if + type is (psb_lc_coo_sparse_mat) + if (present(b)) then + call psb_rwextd(nr,aa,info,b%a,rowscale=rowscale) + else + call psb_rwextd(nr,aa,info,rowscale=rowscale) + end if + class default + call aa%mv_to_coo(actmp,info) + if (info == psb_success_) then + if (present(b)) then + call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale) + else + call psb_rwextd(nr,actmp,info,rowscale=rowscale) + end if + end if + if (info == psb_success_) call aa%mv_from_coo(actmp,info) + end select + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lcrwextd +subroutine psb_lcbase_rwextd(nr,a,info,b,rowscale) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lcbase_rwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer(psb_lpk_), intent(in) :: nr + class(psb_lc_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + class(psb_lc_base_sparse_mat), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer(psb_lpk_) :: i,j,ja,jb,nza,nzb, ma, mb, na, nb + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + logical rowscale_ + + name='psb_lcbase_rwextd' + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .true. + end if + + ma = a%get_nrows() + na = a%get_ncols() + + + select type(a) + type is (psb_lc_csr_sparse_mat) + + call psb_ensure_size(nr+1,a%irp,info) + + if (present(b)) then + mb = b%get_nrows() + nb = b%get_ncols() + nzb = b%get_nzeros() + + select type (b) + type is (psb_lc_csr_sparse_mat) + call psb_ensure_size(size(a%ja)+nzb,a%ja,info) + call psb_ensure_size(size(a%val)+nzb,a%val,info) + do i=1, min(nr-ma,mb) + a%irp(ma+i+1) = a%irp(ma+i) + b%irp(i+1) - b%irp(i) + ja = a%irp(ma+i) + do jb = b%irp(i), b%irp(i+1)-1 + a%val(ja) = b%val(jb) + a%ja(ja) = b%ja(jb) + ja = ja + 1 + end do + end do + do j=i,nr-ma + a%irp(ma+i+1) = a%irp(ma+i) + end do + class default + + write(psb_err_unit,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + end select + call a%set_ncols(max(na,nb)) + + else + + do i=ma+2,nr+1 + a%irp(i) = a%irp(i-1) + end do + + end if + + call a%set_nrows(nr) + + + type is (psb_lc_coo_sparse_mat) + nza = a%get_nzeros() + + if (present(b)) then + mb = b%get_nrows() + nb = b%get_ncols() + nzb = b%get_nzeros() + call a%reallocate(nza+nzb) + + select type(b) + type is (psb_lc_coo_sparse_mat) + + if (rowscale_) then + do j=1,nzb + if ((ma + b%ia(j)) <= nr) then + nza = nza + 1 + a%ia(nza) = ma + b%ia(j) + a%ja(nza) = b%ja(j) + a%val(nza) = b%val(j) + end if + enddo + else + do j=1,nzb + if ((ma + b%ia(j)) <= nr) then + nza = nza + 1 + a%ia(nza) = b%ia(j) + a%ja(nza) = b%ja(j) + a%val(nza) = b%val(j) + end if + enddo + endif + call a%set_nzeros(nza) + + type is (psb_lc_csr_sparse_mat) + + do i=1, min(nr-ma,mb) + do jb = b%irp(i), b%irp(i+1)-1 + nza = nza + 1 + a%val(nza) = b%val(jb) + a%ia(nza) = ma + i + a%ja(nza) = b%ja(jb) + end do + end do + call a%set_nzeros(nza) + + class default + write(psb_err_unit,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + + end select + + call a%set_ncols(max(na,nb)) + endif + + call a%set_nrows(nr) + + class default + info = psb_err_unsupported_format_ + ch_err=a%get_fmt() + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lcbase_rwextd diff --git a/base/serial/psb_cspspmm.f90 b/base/serial/psb_cspspmm.f90 index d54dde988..ef56757e3 100644 --- a/base/serial/psb_cspspmm.f90 +++ b/base/serial/psb_cspspmm.f90 @@ -115,3 +115,84 @@ subroutine psb_cspspmm(a,b,c,info) end subroutine psb_cspspmm + +subroutine psb_lcspspmm(a,b,c,info) + use psb_base_mod, psb_protect_name => psb_lcspspmm + implicit none + + type(psb_lcspmat_type), intent(in) :: a,b + type(psb_lcspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + type(psb_lc_csr_sparse_mat), allocatable :: ccsr + type(psb_lc_csc_sparse_mat), allocatable :: ccsc + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_spspmm' + logical :: done_spmm + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! + ! Shortcuts for special cases + ! + done_spmm = .false. + select type(aa=>a%a) + class is (psb_lc_csr_sparse_mat) + select type(ba=>b%a) + class is (psb_lc_csr_sparse_mat) + + allocate(ccsr,stat=info) + if (info == psb_success_) then + call psb_lccsrspspmm(aa,ba,ccsr,info) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(ccsr,c%a) + done_spmm = .true. + + end select + + class is (psb_lc_csc_sparse_mat) + select type(ba=>b%a) + class is (psb_lc_csc_sparse_mat) + + allocate(ccsc,stat=info) + if (info == psb_success_) then + call psb_lccscspspmm(aa,ba,ccsc,info) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(ccsc,c%a) + done_spmm = .true. + + end select + + end select + + ! + ! General code + ! + if (.not.done_spmm) then + call psb_symbmm(a,b,c,info) + if (info == psb_success_) call psb_numbmm(a,b,c) + end if + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lcspspmm + diff --git a/base/serial/psb_csymbmm.f90 b/base/serial/psb_csymbmm.f90 index 3343c61de..25818791d 100644 --- a/base/serial/psb_csymbmm.f90 +++ b/base/serial/psb_csymbmm.f90 @@ -255,3 +255,223 @@ contains end subroutine gen_symbmm end subroutine psb_cbase_symbmm + + + +subroutine psb_lcsymbmm(a,b,c,info) + use psb_base_mod, psb_protect_name => psb_lcsymbmm + implicit none + + type(psb_lcspmat_type), intent(in) :: a,b + type(psb_lcspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + type(psb_lc_csr_sparse_mat), allocatable :: ccsr + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_symbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ccsr,stat=info) + + if (info == psb_success_) then + call psb_symbmm(a%a,b%a,ccsr,info) + else + info = psb_err_alloc_dealloc_ + end if + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call move_alloc(ccsr,c%a) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lcsymbmm + +subroutine psb_lcbase_symbmm(a,b,c,info) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lcbase_symbmm + implicit none + + class(psb_lc_base_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), allocatable :: itemp(:) + integer(psb_lpk_) :: nze, ma,na,mb,nb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_symbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(itemp(max(ma,na,mb,nb)),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + endif + ! + ! Note: we need to test whether there is a performance impact + ! in not using the original Douglas & Bank code. + ! + select type(a) + type is (psb_lc_csr_sparse_mat) + select type(b) + type is (psb_lc_csr_sparse_mat) + call csr_symbmm(a,b,c,itemp,info) + class default + call gen_symbmm(a,b,c,itemp,info) + end select + class default + call gen_symbmm(a,b,c,itemp,info) + end select + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(size(c%ja),c%val,info) + deallocate(itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_symbmm(a,b,c,itemp,info) + type(psb_lc_csr_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_lpk_) :: itemp(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = max(ma+1,2*ma) + call c%allocate(ma,nb,nze) + call lsymbmm(ma,na,nb,a%irp,a%ja,lzero,& + & b%irp,b%ja,lzero,& + & c%irp,c%ja,lzero,itemp) + + end subroutine csr_symbmm + subroutine gen_symbmm(a,b,c,index,info) + class(psb_lc_base_sparse_mat), intent(in) :: a,b + type(psb_lc_csr_sparse_mat), intent(out) :: c + integer(psb_lpk_) :: index(:) + integer(psb_ipk_) :: info + integer(psb_lpk_), allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + integer(psb_lpk_) :: maxlmn,i,j,m,n,k,l,istart,length,nazr,nbzr,jj,minlm,minmn + integer(psb_lpk_) :: nze, ma,na,mb,nb + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = max(ma+1,2*ma) + call c%allocate(ma,nb,nze) + + n = ma + m = na + l = nb + maxlmn = max(l,m,n) + + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + return + endif + + do i=1,maxlmn + index(i)=0 + end do + + c%irp(1)=1 + minlm = min(l,m) + minmn = min(m,n) + + main: do i=1,n + istart=-1 + length=0 + call a%csget(i,i,nazr,iarw,iacl,info) + do jj=1, nazr + + j=iacl(jj) + + if ((j<1).or.(j>m)) then + write(psb_err_unit,*) ' SymbMM: Problem with A ',i,jj,j,m + info = 1 + return + endif + call b%csget(j,j,nbzr,ibrw,ibcl,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(psb_err_unit,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn + info=psb_err_pivot_too_small_ + return + else + if(index(ibcl(k)) == 0) then + index(ibcl(k))=istart + istart=ibcl(k) + length=length+1 + endif + endif + end do + end do + + c%irp(i+1)=c%irp(i)+length + + if (c%irp(i+1) > size(c%ja)) then + if (n > (2*i)) then + nze = max(c%irp(i+1), c%irp(i)*((n+i-1)/i)) + else + nze = max(c%irp(i+1), nint((dble(c%irp(i))*(dble(n)/i))) ) + endif + call psb_realloc(nze,c%ja,info) + end if + do j= c%irp(i),c%irp(i+1)-1 + c%ja(j)=istart + istart=index(istart) + index(c%ja(j))=0 + end do + call psb_msort(c%ja(c%irp(i):c%irp(i)+length-1)) + index(i) = 0 + end do main + + end subroutine gen_symbmm + +end subroutine psb_lcbase_symbmm diff --git a/base/serial/psb_dnumbmm.f90 b/base/serial/psb_dnumbmm.f90 index 2de4b9039..c1d3951cd 100644 --- a/base/serial/psb_dnumbmm.f90 +++ b/base/serial/psb_dnumbmm.f90 @@ -39,7 +39,6 @@ ! rewritten in Fortran 95/2003 making use of our sparse matrix facilities. ! ! - subroutine psb_dnumbmm(a,b,c) use psb_base_mod, psb_protect_name => psb_dnumbmm implicit none @@ -234,3 +233,200 @@ contains end subroutine gen_numbmm end subroutine psb_dbase_numbmm + + + +subroutine psb_ldnumbmm(a,b,c) + use psb_base_mod, psb_protect_name => psb_ldnumbmm + implicit none + + type(psb_ldspmat_type), intent(in) :: a,b + type(psb_ldspmat_type), intent(inout) :: c + integer(psb_ipk_) :: info + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_numbmm' + + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null()).or.(c%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + select type(aa=>c%a) + type is (psb_ld_csr_sparse_mat) + call psb_numbmm(a%a,b%a,aa) + class default + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end select + + call c%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ldnumbmm + +subroutine psb_ldbase_numbmm(a,b,c) + use psb_mat_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_ldbase_numbmm + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_lpk_) :: nze, ma,na,mb,nb + character(len=20) :: name + real(psb_dpk_), allocatable :: temp(:) + integer(psb_ipk_) :: info + integer(psb_ipk_) :: err_act + name='psb_numbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb + endif + allocate(temp(max(ma,na,mb,nb)),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + endif + + ! + ! Note: we still have to test about possible performance hits. + ! + ! + call psb_ensure_size(ione*size(c%ja),c%val,info) + select type(a) + type is (psb_ld_csr_sparse_mat) + select type(b) + type is (psb_ld_csr_sparse_mat) + call csr_numbmm(a,b,c,temp,info) + class default + call gen_numbmm(a,b,c,temp,info) + end select + class default + call gen_numbmm(a,b,c,temp,info) + end select + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call c%set_asb() + deallocate(temp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_numbmm(a,b,c,temp,info) + type(psb_ld_csr_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(inout) :: c + real(psb_dpk_) :: temp(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + call ldnumbmm(ma,na,nb,a%irp,a%ja,lzero,a%val,& + & b%irp,b%ja,lzero,b%val,& + & c%irp,c%ja,lzero,c%val,temp) + + + end subroutine csr_numbmm + + subroutine gen_numbmm(a,b,c,temp,info) + class(psb_ld_base_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_) :: info + real(psb_dpk_) :: temp(:) + integer(psb_lpk_), allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + real(psb_dpk_), allocatable :: aval(:),bval(:) + integer(psb_lpk_) :: maxlmn,i,j,m,n,k,l,nazr,nbzr,jj,minlm,minmn,minln + real(psb_dpk_) :: ajj + + n = a%get_nrows() + m = a%get_ncols() + l = b%get_ncols() + maxlmn = max(l,m,n) + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & aval(maxlmn),bval(maxlmn), stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + return + endif + + do i = 1,maxlmn + temp(i) = dzero + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + do i = 1,n + + call a%csget(i,i,nazr,iarw,iacl,aval,info) + do jj=1, nazr + j=iacl(jj) + ajj = aval(jj) + if ((j<1).or.(j>m)) then + write(psb_err_unit,*) ' NUMBMM: Problem with A ',i,jj,j,m + info = 1 + return + + endif + call b%csget(j,j,nbzr,ibrw,ibcl,bval,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(psb_err_unit,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn + info = psb_err_pivot_too_small_ + return + else + temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) + endif + enddo + end do + do j = c%irp(i),c%irp(i+1)-1 + if((c%ja(j)<1).or. (c%ja(j) > maxlmn)) then + write(psb_err_unit,*) ' NUMBMM: output problem',i,j,c%ja(j),maxlmn + info = psb_err_invalid_ovr_num_ + return + else + c%val(j) = temp(c%ja(j)) + temp(c%ja(j)) = dzero + endif + end do + end do + + + end subroutine gen_numbmm + +end subroutine psb_ldbase_numbmm diff --git a/base/serial/psb_drwextd.f90 b/base/serial/psb_drwextd.f90 index c2f39473f..29898578d 100644 --- a/base/serial/psb_drwextd.f90 +++ b/base/serial/psb_drwextd.f90 @@ -35,17 +35,18 @@ ! ! We have a problem here: 1. How to handle well all the formats? ! 2. What should we do with rowscale? Does it only -! apply when a%fida='COO' ?????? +! apply when a%fmt()='COO' ?????? ! ! subroutine psb_drwextd(nr,a,info,b,rowscale) - use psb_base_mod, psb_protect_name => psb_drwextd + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_drwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr type(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info type(psb_dspmat_type), intent(in), optional :: b logical,intent(in), optional :: rowscale @@ -89,23 +90,20 @@ subroutine psb_drwextd(nr,a,info,b,rowscale) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if +9999 call psb_error_handler(err_act) + return end subroutine psb_drwextd subroutine psb_dbase_rwextd(nr,a,info,b,rowscale) - use psb_base_mod, psb_protect_name => psb_dbase_rwextd + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_dbase_rwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr class(psb_d_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info class(psb_d_base_sparse_mat), intent(in), optional :: b logical,intent(in), optional :: rowscale @@ -174,8 +172,8 @@ subroutine psb_dbase_rwextd(nr,a,info,b,rowscale) nza = a%get_nzeros() if (present(b)) then - mb = b%get_nrows() - nb = b%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() nzb = b%get_nzeros() call a%reallocate(nza+nzb) @@ -236,12 +234,213 @@ subroutine psb_dbase_rwextd(nr,a,info,b,rowscale) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if +9999 call psb_error_handler(err_act) + return end subroutine psb_dbase_rwextd + + +subroutine psb_ldrwextd(nr,a,info,b,rowscale) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_ldrwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer(psb_lpk_), intent(in) :: nr + type(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + type(psb_ldspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer(psb_lpk_) :: i,j,ja,jb,nza,nzb + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + type(psb_ld_coo_sparse_mat) :: actmp + logical rowscale_ + + name='psb_ldrwextd' + info = psb_success_ + call psb_erractionsave(err_act) + + if (nr > a%get_nrows()) then + select type(aa=> a%a) + type is (psb_ld_csr_sparse_mat) + if (present(b)) then + call psb_rwextd(nr,aa,info,b%a,rowscale) + else + call psb_rwextd(nr,aa,info,rowscale=rowscale) + end if + type is (psb_ld_coo_sparse_mat) + if (present(b)) then + call psb_rwextd(nr,aa,info,b%a,rowscale=rowscale) + else + call psb_rwextd(nr,aa,info,rowscale=rowscale) + end if + class default + call aa%mv_to_coo(actmp,info) + if (info == psb_success_) then + if (present(b)) then + call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale) + else + call psb_rwextd(nr,actmp,info,rowscale=rowscale) + end if + end if + if (info == psb_success_) call aa%mv_from_coo(actmp,info) + end select + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ldrwextd +subroutine psb_ldbase_rwextd(nr,a,info,b,rowscale) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_ldbase_rwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer(psb_lpk_), intent(in) :: nr + class(psb_ld_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + class(psb_ld_base_sparse_mat), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer(psb_lpk_) :: i,j,ja,jb,nza,nzb, ma, mb, na, nb + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + logical rowscale_ + + name='psb_ldbase_rwextd' + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .true. + end if + + ma = a%get_nrows() + na = a%get_ncols() + + + select type(a) + type is (psb_ld_csr_sparse_mat) + + call psb_ensure_size(nr+1,a%irp,info) + + if (present(b)) then + mb = b%get_nrows() + nb = b%get_ncols() + nzb = b%get_nzeros() + + select type (b) + type is (psb_ld_csr_sparse_mat) + call psb_ensure_size(size(a%ja)+nzb,a%ja,info) + call psb_ensure_size(size(a%val)+nzb,a%val,info) + do i=1, min(nr-ma,mb) + a%irp(ma+i+1) = a%irp(ma+i) + b%irp(i+1) - b%irp(i) + ja = a%irp(ma+i) + do jb = b%irp(i), b%irp(i+1)-1 + a%val(ja) = b%val(jb) + a%ja(ja) = b%ja(jb) + ja = ja + 1 + end do + end do + do j=i,nr-ma + a%irp(ma+i+1) = a%irp(ma+i) + end do + class default + + write(psb_err_unit,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + end select + call a%set_ncols(max(na,nb)) + + else + + do i=ma+2,nr+1 + a%irp(i) = a%irp(i-1) + end do + + end if + + call a%set_nrows(nr) + + + type is (psb_ld_coo_sparse_mat) + nza = a%get_nzeros() + + if (present(b)) then + mb = b%get_nrows() + nb = b%get_ncols() + nzb = b%get_nzeros() + call a%reallocate(nza+nzb) + + select type(b) + type is (psb_ld_coo_sparse_mat) + + if (rowscale_) then + do j=1,nzb + if ((ma + b%ia(j)) <= nr) then + nza = nza + 1 + a%ia(nza) = ma + b%ia(j) + a%ja(nza) = b%ja(j) + a%val(nza) = b%val(j) + end if + enddo + else + do j=1,nzb + if ((ma + b%ia(j)) <= nr) then + nza = nza + 1 + a%ia(nza) = b%ia(j) + a%ja(nza) = b%ja(j) + a%val(nza) = b%val(j) + end if + enddo + endif + call a%set_nzeros(nza) + + type is (psb_ld_csr_sparse_mat) + + do i=1, min(nr-ma,mb) + do jb = b%irp(i), b%irp(i+1)-1 + nza = nza + 1 + a%val(nza) = b%val(jb) + a%ia(nza) = ma + i + a%ja(nza) = b%ja(jb) + end do + end do + call a%set_nzeros(nza) + + class default + write(psb_err_unit,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + + end select + + call a%set_ncols(max(na,nb)) + endif + + call a%set_nrows(nr) + + class default + info = psb_err_unsupported_format_ + ch_err=a%get_fmt() + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ldbase_rwextd diff --git a/base/serial/psb_dspspmm.f90 b/base/serial/psb_dspspmm.f90 index f0fff17c9..cec9699ae 100644 --- a/base/serial/psb_dspspmm.f90 +++ b/base/serial/psb_dspspmm.f90 @@ -115,3 +115,84 @@ subroutine psb_dspspmm(a,b,c,info) end subroutine psb_dspspmm + +subroutine psb_ldspspmm(a,b,c,info) + use psb_base_mod, psb_protect_name => psb_ldspspmm + implicit none + + type(psb_ldspmat_type), intent(in) :: a,b + type(psb_ldspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + type(psb_ld_csr_sparse_mat), allocatable :: ccsr + type(psb_ld_csc_sparse_mat), allocatable :: ccsc + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_spspmm' + logical :: done_spmm + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! + ! Shortcuts for special cases + ! + done_spmm = .false. + select type(aa=>a%a) + class is (psb_ld_csr_sparse_mat) + select type(ba=>b%a) + class is (psb_ld_csr_sparse_mat) + + allocate(ccsr,stat=info) + if (info == psb_success_) then + call psb_ldcsrspspmm(aa,ba,ccsr,info) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(ccsr,c%a) + done_spmm = .true. + + end select + + class is (psb_ld_csc_sparse_mat) + select type(ba=>b%a) + class is (psb_ld_csc_sparse_mat) + + allocate(ccsc,stat=info) + if (info == psb_success_) then + call psb_ldcscspspmm(aa,ba,ccsc,info) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(ccsc,c%a) + done_spmm = .true. + + end select + + end select + + ! + ! General code + ! + if (.not.done_spmm) then + call psb_symbmm(a,b,c,info) + if (info == psb_success_) call psb_numbmm(a,b,c) + end if + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ldspspmm + diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index 848a5cfd0..3dcad00f9 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -255,3 +255,223 @@ contains end subroutine gen_symbmm end subroutine psb_dbase_symbmm + + + +subroutine psb_ldsymbmm(a,b,c,info) + use psb_base_mod, psb_protect_name => psb_ldsymbmm + implicit none + + type(psb_ldspmat_type), intent(in) :: a,b + type(psb_ldspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + type(psb_ld_csr_sparse_mat), allocatable :: ccsr + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_symbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ccsr,stat=info) + + if (info == psb_success_) then + call psb_symbmm(a%a,b%a,ccsr,info) + else + info = psb_err_alloc_dealloc_ + end if + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call move_alloc(ccsr,c%a) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_ldsymbmm + +subroutine psb_ldbase_symbmm(a,b,c,info) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_ldbase_symbmm + implicit none + + class(psb_ld_base_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), allocatable :: itemp(:) + integer(psb_lpk_) :: nze, ma,na,mb,nb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_symbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(itemp(max(ma,na,mb,nb)),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + endif + ! + ! Note: we need to test whether there is a performance impact + ! in not using the original Douglas & Bank code. + ! + select type(a) + type is (psb_ld_csr_sparse_mat) + select type(b) + type is (psb_ld_csr_sparse_mat) + call csr_symbmm(a,b,c,itemp,info) + class default + call gen_symbmm(a,b,c,itemp,info) + end select + class default + call gen_symbmm(a,b,c,itemp,info) + end select + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(size(c%ja),c%val,info) + deallocate(itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_symbmm(a,b,c,itemp,info) + type(psb_ld_csr_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_lpk_) :: itemp(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = max(ma+1,2*ma) + call c%allocate(ma,nb,nze) + call lsymbmm(ma,na,nb,a%irp,a%ja,lzero,& + & b%irp,b%ja,lzero,& + & c%irp,c%ja,lzero,itemp) + + end subroutine csr_symbmm + subroutine gen_symbmm(a,b,c,index,info) + class(psb_ld_base_sparse_mat), intent(in) :: a,b + type(psb_ld_csr_sparse_mat), intent(out) :: c + integer(psb_lpk_) :: index(:) + integer(psb_ipk_) :: info + integer(psb_lpk_), allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + integer(psb_lpk_) :: maxlmn,i,j,m,n,k,l,istart,length,nazr,nbzr,jj,minlm,minmn + integer(psb_lpk_) :: nze, ma,na,mb,nb + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = max(ma+1,2*ma) + call c%allocate(ma,nb,nze) + + n = ma + m = na + l = nb + maxlmn = max(l,m,n) + + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + return + endif + + do i=1,maxlmn + index(i)=0 + end do + + c%irp(1)=1 + minlm = min(l,m) + minmn = min(m,n) + + main: do i=1,n + istart=-1 + length=0 + call a%csget(i,i,nazr,iarw,iacl,info) + do jj=1, nazr + + j=iacl(jj) + + if ((j<1).or.(j>m)) then + write(psb_err_unit,*) ' SymbMM: Problem with A ',i,jj,j,m + info = 1 + return + endif + call b%csget(j,j,nbzr,ibrw,ibcl,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(psb_err_unit,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn + info=psb_err_pivot_too_small_ + return + else + if(index(ibcl(k)) == 0) then + index(ibcl(k))=istart + istart=ibcl(k) + length=length+1 + endif + endif + end do + end do + + c%irp(i+1)=c%irp(i)+length + + if (c%irp(i+1) > size(c%ja)) then + if (n > (2*i)) then + nze = max(c%irp(i+1), c%irp(i)*((n+i-1)/i)) + else + nze = max(c%irp(i+1), nint((dble(c%irp(i))*(dble(n)/i))) ) + endif + call psb_realloc(nze,c%ja,info) + end if + do j= c%irp(i),c%irp(i+1)-1 + c%ja(j)=istart + istart=index(istart) + index(c%ja(j))=0 + end do + call psb_msort(c%ja(c%irp(i):c%irp(i)+length-1)) + index(i) = 0 + end do main + + end subroutine gen_symbmm + +end subroutine psb_ldbase_symbmm diff --git a/base/serial/psb_snumbmm.f90 b/base/serial/psb_snumbmm.f90 index 9b37a10af..ceffb977c 100644 --- a/base/serial/psb_snumbmm.f90 +++ b/base/serial/psb_snumbmm.f90 @@ -39,7 +39,6 @@ ! rewritten in Fortran 95/2003 making use of our sparse matrix facilities. ! ! - subroutine psb_snumbmm(a,b,c) use psb_base_mod, psb_protect_name => psb_snumbmm implicit none @@ -234,3 +233,200 @@ contains end subroutine gen_numbmm end subroutine psb_sbase_numbmm + + + +subroutine psb_lsnumbmm(a,b,c) + use psb_base_mod, psb_protect_name => psb_lsnumbmm + implicit none + + type(psb_lsspmat_type), intent(in) :: a,b + type(psb_lsspmat_type), intent(inout) :: c + integer(psb_ipk_) :: info + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_numbmm' + + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null()).or.(c%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + select type(aa=>c%a) + type is (psb_ls_csr_sparse_mat) + call psb_numbmm(a%a,b%a,aa) + class default + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end select + + call c%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lsnumbmm + +subroutine psb_lsbase_numbmm(a,b,c) + use psb_mat_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_lsbase_numbmm + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_lpk_) :: nze, ma,na,mb,nb + character(len=20) :: name + real(psb_spk_), allocatable :: temp(:) + integer(psb_ipk_) :: info + integer(psb_ipk_) :: err_act + name='psb_numbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb + endif + allocate(temp(max(ma,na,mb,nb)),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + endif + + ! + ! Note: we still have to test about possible performance hits. + ! + ! + call psb_ensure_size(ione*size(c%ja),c%val,info) + select type(a) + type is (psb_ls_csr_sparse_mat) + select type(b) + type is (psb_ls_csr_sparse_mat) + call csr_numbmm(a,b,c,temp,info) + class default + call gen_numbmm(a,b,c,temp,info) + end select + class default + call gen_numbmm(a,b,c,temp,info) + end select + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call c%set_asb() + deallocate(temp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_numbmm(a,b,c,temp,info) + type(psb_ls_csr_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(inout) :: c + real(psb_spk_) :: temp(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + call lsnumbmm(ma,na,nb,a%irp,a%ja,lzero,a%val,& + & b%irp,b%ja,lzero,b%val,& + & c%irp,c%ja,lzero,c%val,temp) + + + end subroutine csr_numbmm + + subroutine gen_numbmm(a,b,c,temp,info) + class(psb_ls_base_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_) :: info + real(psb_spk_) :: temp(:) + integer(psb_lpk_), allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + real(psb_spk_), allocatable :: aval(:),bval(:) + integer(psb_lpk_) :: maxlmn,i,j,m,n,k,l,nazr,nbzr,jj,minlm,minmn,minln + real(psb_spk_) :: ajj + + n = a%get_nrows() + m = a%get_ncols() + l = b%get_ncols() + maxlmn = max(l,m,n) + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & aval(maxlmn),bval(maxlmn), stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + return + endif + + do i = 1,maxlmn + temp(i) = szero + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + do i = 1,n + + call a%csget(i,i,nazr,iarw,iacl,aval,info) + do jj=1, nazr + j=iacl(jj) + ajj = aval(jj) + if ((j<1).or.(j>m)) then + write(psb_err_unit,*) ' NUMBMM: Problem with A ',i,jj,j,m + info = 1 + return + + endif + call b%csget(j,j,nbzr,ibrw,ibcl,bval,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(psb_err_unit,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn + info = psb_err_pivot_too_small_ + return + else + temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) + endif + enddo + end do + do j = c%irp(i),c%irp(i+1)-1 + if((c%ja(j)<1).or. (c%ja(j) > maxlmn)) then + write(psb_err_unit,*) ' NUMBMM: output problem',i,j,c%ja(j),maxlmn + info = psb_err_invalid_ovr_num_ + return + else + c%val(j) = temp(c%ja(j)) + temp(c%ja(j)) = szero + endif + end do + end do + + + end subroutine gen_numbmm + +end subroutine psb_lsbase_numbmm diff --git a/base/serial/psb_srwextd.f90 b/base/serial/psb_srwextd.f90 index 4e286d38e..6fc533344 100644 --- a/base/serial/psb_srwextd.f90 +++ b/base/serial/psb_srwextd.f90 @@ -35,17 +35,18 @@ ! ! We have a problem here: 1. How to handle well all the formats? ! 2. What should we do with rowscale? Does it only -! apply when a%fida='COO' ?????? +! apply when a%fmt()='COO' ?????? ! ! subroutine psb_srwextd(nr,a,info,b,rowscale) - use psb_base_mod, psb_protect_name => psb_srwextd + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_srwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr type(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info type(psb_sspmat_type), intent(in), optional :: b logical,intent(in), optional :: rowscale @@ -89,23 +90,20 @@ subroutine psb_srwextd(nr,a,info,b,rowscale) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if +9999 call psb_error_handler(err_act) + return end subroutine psb_srwextd subroutine psb_sbase_rwextd(nr,a,info,b,rowscale) - use psb_base_mod, psb_protect_name => psb_sbase_rwextd + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_sbase_rwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr class(psb_s_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: b logical,intent(in), optional :: rowscale @@ -236,12 +234,213 @@ subroutine psb_sbase_rwextd(nr,a,info,b,rowscale) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if +9999 call psb_error_handler(err_act) + return end subroutine psb_sbase_rwextd + + +subroutine psb_lsrwextd(nr,a,info,b,rowscale) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lsrwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer(psb_lpk_), intent(in) :: nr + type(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + type(psb_lsspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer(psb_lpk_) :: i,j,ja,jb,nza,nzb + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + type(psb_ls_coo_sparse_mat) :: actmp + logical rowscale_ + + name='psb_lsrwextd' + info = psb_success_ + call psb_erractionsave(err_act) + + if (nr > a%get_nrows()) then + select type(aa=> a%a) + type is (psb_ls_csr_sparse_mat) + if (present(b)) then + call psb_rwextd(nr,aa,info,b%a,rowscale) + else + call psb_rwextd(nr,aa,info,rowscale=rowscale) + end if + type is (psb_ls_coo_sparse_mat) + if (present(b)) then + call psb_rwextd(nr,aa,info,b%a,rowscale=rowscale) + else + call psb_rwextd(nr,aa,info,rowscale=rowscale) + end if + class default + call aa%mv_to_coo(actmp,info) + if (info == psb_success_) then + if (present(b)) then + call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale) + else + call psb_rwextd(nr,actmp,info,rowscale=rowscale) + end if + end if + if (info == psb_success_) call aa%mv_from_coo(actmp,info) + end select + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lsrwextd +subroutine psb_lsbase_rwextd(nr,a,info,b,rowscale) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lsbase_rwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer(psb_lpk_), intent(in) :: nr + class(psb_ls_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + class(psb_ls_base_sparse_mat), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer(psb_lpk_) :: i,j,ja,jb,nza,nzb, ma, mb, na, nb + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + logical rowscale_ + + name='psb_lsbase_rwextd' + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .true. + end if + + ma = a%get_nrows() + na = a%get_ncols() + + + select type(a) + type is (psb_ls_csr_sparse_mat) + + call psb_ensure_size(nr+1,a%irp,info) + + if (present(b)) then + mb = b%get_nrows() + nb = b%get_ncols() + nzb = b%get_nzeros() + + select type (b) + type is (psb_ls_csr_sparse_mat) + call psb_ensure_size(size(a%ja)+nzb,a%ja,info) + call psb_ensure_size(size(a%val)+nzb,a%val,info) + do i=1, min(nr-ma,mb) + a%irp(ma+i+1) = a%irp(ma+i) + b%irp(i+1) - b%irp(i) + ja = a%irp(ma+i) + do jb = b%irp(i), b%irp(i+1)-1 + a%val(ja) = b%val(jb) + a%ja(ja) = b%ja(jb) + ja = ja + 1 + end do + end do + do j=i,nr-ma + a%irp(ma+i+1) = a%irp(ma+i) + end do + class default + + write(psb_err_unit,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + end select + call a%set_ncols(max(na,nb)) + + else + + do i=ma+2,nr+1 + a%irp(i) = a%irp(i-1) + end do + + end if + + call a%set_nrows(nr) + + + type is (psb_ls_coo_sparse_mat) + nza = a%get_nzeros() + + if (present(b)) then + mb = b%get_nrows() + nb = b%get_ncols() + nzb = b%get_nzeros() + call a%reallocate(nza+nzb) + + select type(b) + type is (psb_ls_coo_sparse_mat) + + if (rowscale_) then + do j=1,nzb + if ((ma + b%ia(j)) <= nr) then + nza = nza + 1 + a%ia(nza) = ma + b%ia(j) + a%ja(nza) = b%ja(j) + a%val(nza) = b%val(j) + end if + enddo + else + do j=1,nzb + if ((ma + b%ia(j)) <= nr) then + nza = nza + 1 + a%ia(nza) = b%ia(j) + a%ja(nza) = b%ja(j) + a%val(nza) = b%val(j) + end if + enddo + endif + call a%set_nzeros(nza) + + type is (psb_ls_csr_sparse_mat) + + do i=1, min(nr-ma,mb) + do jb = b%irp(i), b%irp(i+1)-1 + nza = nza + 1 + a%val(nza) = b%val(jb) + a%ia(nza) = ma + i + a%ja(nza) = b%ja(jb) + end do + end do + call a%set_nzeros(nza) + + class default + write(psb_err_unit,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + + end select + + call a%set_ncols(max(na,nb)) + endif + + call a%set_nrows(nr) + + class default + info = psb_err_unsupported_format_ + ch_err=a%get_fmt() + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lsbase_rwextd diff --git a/base/serial/psb_sspspmm.f90 b/base/serial/psb_sspspmm.f90 index 6e521a4c9..008bcce62 100644 --- a/base/serial/psb_sspspmm.f90 +++ b/base/serial/psb_sspspmm.f90 @@ -115,3 +115,84 @@ subroutine psb_sspspmm(a,b,c,info) end subroutine psb_sspspmm + +subroutine psb_lsspspmm(a,b,c,info) + use psb_base_mod, psb_protect_name => psb_lsspspmm + implicit none + + type(psb_lsspmat_type), intent(in) :: a,b + type(psb_lsspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + type(psb_ls_csr_sparse_mat), allocatable :: ccsr + type(psb_ls_csc_sparse_mat), allocatable :: ccsc + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_spspmm' + logical :: done_spmm + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! + ! Shortcuts for special cases + ! + done_spmm = .false. + select type(aa=>a%a) + class is (psb_ls_csr_sparse_mat) + select type(ba=>b%a) + class is (psb_ls_csr_sparse_mat) + + allocate(ccsr,stat=info) + if (info == psb_success_) then + call psb_lscsrspspmm(aa,ba,ccsr,info) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(ccsr,c%a) + done_spmm = .true. + + end select + + class is (psb_ls_csc_sparse_mat) + select type(ba=>b%a) + class is (psb_ls_csc_sparse_mat) + + allocate(ccsc,stat=info) + if (info == psb_success_) then + call psb_lscscspspmm(aa,ba,ccsc,info) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(ccsc,c%a) + done_spmm = .true. + + end select + + end select + + ! + ! General code + ! + if (.not.done_spmm) then + call psb_symbmm(a,b,c,info) + if (info == psb_success_) call psb_numbmm(a,b,c) + end if + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lsspspmm + diff --git a/base/serial/psb_ssymbmm.f90 b/base/serial/psb_ssymbmm.f90 index e9d10c0b1..729dd856b 100644 --- a/base/serial/psb_ssymbmm.f90 +++ b/base/serial/psb_ssymbmm.f90 @@ -255,3 +255,223 @@ contains end subroutine gen_symbmm end subroutine psb_sbase_symbmm + + + +subroutine psb_lssymbmm(a,b,c,info) + use psb_base_mod, psb_protect_name => psb_lssymbmm + implicit none + + type(psb_lsspmat_type), intent(in) :: a,b + type(psb_lsspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + type(psb_ls_csr_sparse_mat), allocatable :: ccsr + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_symbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ccsr,stat=info) + + if (info == psb_success_) then + call psb_symbmm(a%a,b%a,ccsr,info) + else + info = psb_err_alloc_dealloc_ + end if + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call move_alloc(ccsr,c%a) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lssymbmm + +subroutine psb_lsbase_symbmm(a,b,c,info) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lsbase_symbmm + implicit none + + class(psb_ls_base_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), allocatable :: itemp(:) + integer(psb_lpk_) :: nze, ma,na,mb,nb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_symbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(itemp(max(ma,na,mb,nb)),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + endif + ! + ! Note: we need to test whether there is a performance impact + ! in not using the original Douglas & Bank code. + ! + select type(a) + type is (psb_ls_csr_sparse_mat) + select type(b) + type is (psb_ls_csr_sparse_mat) + call csr_symbmm(a,b,c,itemp,info) + class default + call gen_symbmm(a,b,c,itemp,info) + end select + class default + call gen_symbmm(a,b,c,itemp,info) + end select + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(size(c%ja),c%val,info) + deallocate(itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_symbmm(a,b,c,itemp,info) + type(psb_ls_csr_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_lpk_) :: itemp(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = max(ma+1,2*ma) + call c%allocate(ma,nb,nze) + call lsymbmm(ma,na,nb,a%irp,a%ja,lzero,& + & b%irp,b%ja,lzero,& + & c%irp,c%ja,lzero,itemp) + + end subroutine csr_symbmm + subroutine gen_symbmm(a,b,c,index,info) + class(psb_ls_base_sparse_mat), intent(in) :: a,b + type(psb_ls_csr_sparse_mat), intent(out) :: c + integer(psb_lpk_) :: index(:) + integer(psb_ipk_) :: info + integer(psb_lpk_), allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + integer(psb_lpk_) :: maxlmn,i,j,m,n,k,l,istart,length,nazr,nbzr,jj,minlm,minmn + integer(psb_lpk_) :: nze, ma,na,mb,nb + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = max(ma+1,2*ma) + call c%allocate(ma,nb,nze) + + n = ma + m = na + l = nb + maxlmn = max(l,m,n) + + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + return + endif + + do i=1,maxlmn + index(i)=0 + end do + + c%irp(1)=1 + minlm = min(l,m) + minmn = min(m,n) + + main: do i=1,n + istart=-1 + length=0 + call a%csget(i,i,nazr,iarw,iacl,info) + do jj=1, nazr + + j=iacl(jj) + + if ((j<1).or.(j>m)) then + write(psb_err_unit,*) ' SymbMM: Problem with A ',i,jj,j,m + info = 1 + return + endif + call b%csget(j,j,nbzr,ibrw,ibcl,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(psb_err_unit,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn + info=psb_err_pivot_too_small_ + return + else + if(index(ibcl(k)) == 0) then + index(ibcl(k))=istart + istart=ibcl(k) + length=length+1 + endif + endif + end do + end do + + c%irp(i+1)=c%irp(i)+length + + if (c%irp(i+1) > size(c%ja)) then + if (n > (2*i)) then + nze = max(c%irp(i+1), c%irp(i)*((n+i-1)/i)) + else + nze = max(c%irp(i+1), nint((dble(c%irp(i))*(dble(n)/i))) ) + endif + call psb_realloc(nze,c%ja,info) + end if + do j= c%irp(i),c%irp(i+1)-1 + c%ja(j)=istart + istart=index(istart) + index(c%ja(j))=0 + end do + call psb_msort(c%ja(c%irp(i):c%irp(i)+length-1)) + index(i) = 0 + end do main + + end subroutine gen_symbmm + +end subroutine psb_lsbase_symbmm diff --git a/base/serial/psb_znumbmm.f90 b/base/serial/psb_znumbmm.f90 index 130de6ebe..be4e10263 100644 --- a/base/serial/psb_znumbmm.f90 +++ b/base/serial/psb_znumbmm.f90 @@ -39,7 +39,6 @@ ! rewritten in Fortran 95/2003 making use of our sparse matrix facilities. ! ! - subroutine psb_znumbmm(a,b,c) use psb_base_mod, psb_protect_name => psb_znumbmm implicit none @@ -234,3 +233,200 @@ contains end subroutine gen_numbmm end subroutine psb_zbase_numbmm + + + +subroutine psb_lznumbmm(a,b,c) + use psb_base_mod, psb_protect_name => psb_lznumbmm + implicit none + + type(psb_lzspmat_type), intent(in) :: a,b + type(psb_lzspmat_type), intent(inout) :: c + integer(psb_ipk_) :: info + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_numbmm' + + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null()).or.(c%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + select type(aa=>c%a) + type is (psb_lz_csr_sparse_mat) + call psb_numbmm(a%a,b%a,aa) + class default + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + end select + + call c%set_asb() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lznumbmm + +subroutine psb_lzbase_numbmm(a,b,c) + use psb_mat_mod + use psb_string_mod + use psb_serial_mod, psb_protect_name => psb_lzbase_numbmm + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_), allocatable :: itemp(:) + integer(psb_lpk_) :: nze, ma,na,mb,nb + character(len=20) :: name + complex(psb_dpk_), allocatable :: temp(:) + integer(psb_ipk_) :: info + integer(psb_ipk_) :: err_act + name='psb_numbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb + endif + allocate(temp(max(ma,na,mb,nb)),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + endif + + ! + ! Note: we still have to test about possible performance hits. + ! + ! + call psb_ensure_size(ione*size(c%ja),c%val,info) + select type(a) + type is (psb_lz_csr_sparse_mat) + select type(b) + type is (psb_lz_csr_sparse_mat) + call csr_numbmm(a,b,c,temp,info) + class default + call gen_numbmm(a,b,c,temp,info) + end select + class default + call gen_numbmm(a,b,c,temp,info) + end select + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call c%set_asb() + deallocate(temp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_numbmm(a,b,c,temp,info) + type(psb_lz_csr_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(inout) :: c + complex(psb_dpk_) :: temp(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + call lznumbmm(ma,na,nb,a%irp,a%ja,lzero,a%val,& + & b%irp,b%ja,lzero,b%val,& + & c%irp,c%ja,lzero,c%val,temp) + + + end subroutine csr_numbmm + + subroutine gen_numbmm(a,b,c,temp,info) + class(psb_lz_base_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(inout) :: c + integer(psb_ipk_) :: info + complex(psb_dpk_) :: temp(:) + integer(psb_lpk_), allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + complex(psb_dpk_), allocatable :: aval(:),bval(:) + integer(psb_lpk_) :: maxlmn,i,j,m,n,k,l,nazr,nbzr,jj,minlm,minmn,minln + complex(psb_dpk_) :: ajj + + n = a%get_nrows() + m = a%get_ncols() + l = b%get_ncols() + maxlmn = max(l,m,n) + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & aval(maxlmn),bval(maxlmn), stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + return + endif + + do i = 1,maxlmn + temp(i) = zzero + end do + minlm = min(l,m) + minln = min(l,n) + minmn = min(m,n) + do i = 1,n + + call a%csget(i,i,nazr,iarw,iacl,aval,info) + do jj=1, nazr + j=iacl(jj) + ajj = aval(jj) + if ((j<1).or.(j>m)) then + write(psb_err_unit,*) ' NUMBMM: Problem with A ',i,jj,j,m + info = 1 + return + + endif + call b%csget(j,j,nbzr,ibrw,ibcl,bval,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(psb_err_unit,*) 'Problem in NUMBM 1:',j,k,ibcl(k),maxlmn + info = psb_err_pivot_too_small_ + return + else + temp(ibcl(k)) = temp(ibcl(k)) + ajj * bval(k) + endif + enddo + end do + do j = c%irp(i),c%irp(i+1)-1 + if((c%ja(j)<1).or. (c%ja(j) > maxlmn)) then + write(psb_err_unit,*) ' NUMBMM: output problem',i,j,c%ja(j),maxlmn + info = psb_err_invalid_ovr_num_ + return + else + c%val(j) = temp(c%ja(j)) + temp(c%ja(j)) = zzero + endif + end do + end do + + + end subroutine gen_numbmm + +end subroutine psb_lzbase_numbmm diff --git a/base/serial/psb_zrwextd.f90 b/base/serial/psb_zrwextd.f90 index a45beedc9..949017bc4 100644 --- a/base/serial/psb_zrwextd.f90 +++ b/base/serial/psb_zrwextd.f90 @@ -35,17 +35,18 @@ ! ! We have a problem here: 1. How to handle well all the formats? ! 2. What should we do with rowscale? Does it only -! apply when a%fida='COO' ?????? +! apply when a%fmt()='COO' ?????? ! ! subroutine psb_zrwextd(nr,a,info,b,rowscale) - use psb_base_mod, psb_protect_name => psb_zrwextd + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_zrwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr type(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info type(psb_zspmat_type), intent(in), optional :: b logical,intent(in), optional :: rowscale @@ -89,23 +90,20 @@ subroutine psb_zrwextd(nr,a,info,b,rowscale) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if +9999 call psb_error_handler(err_act) + return end subroutine psb_zrwextd subroutine psb_zbase_rwextd(nr,a,info,b,rowscale) - use psb_base_mod, psb_protect_name => psb_zbase_rwextd + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_zbase_rwextd implicit none ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) - integer(psb_ipk_), intent(in) :: nr + integer(psb_ipk_), intent(in) :: nr class(psb_z_base_sparse_mat), intent(inout) :: a - integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_),intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: b logical,intent(in), optional :: rowscale @@ -236,12 +234,213 @@ subroutine psb_zbase_rwextd(nr,a,info,b,rowscale) call psb_erractionrestore(err_act) return -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if +9999 call psb_error_handler(err_act) + return end subroutine psb_zbase_rwextd + + +subroutine psb_lzrwextd(nr,a,info,b,rowscale) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lzrwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer(psb_lpk_), intent(in) :: nr + type(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + type(psb_lzspmat_type), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer(psb_lpk_) :: i,j,ja,jb,nza,nzb + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + type(psb_lz_coo_sparse_mat) :: actmp + logical rowscale_ + + name='psb_lzrwextd' + info = psb_success_ + call psb_erractionsave(err_act) + + if (nr > a%get_nrows()) then + select type(aa=> a%a) + type is (psb_lz_csr_sparse_mat) + if (present(b)) then + call psb_rwextd(nr,aa,info,b%a,rowscale) + else + call psb_rwextd(nr,aa,info,rowscale=rowscale) + end if + type is (psb_lz_coo_sparse_mat) + if (present(b)) then + call psb_rwextd(nr,aa,info,b%a,rowscale=rowscale) + else + call psb_rwextd(nr,aa,info,rowscale=rowscale) + end if + class default + call aa%mv_to_coo(actmp,info) + if (info == psb_success_) then + if (present(b)) then + call psb_rwextd(nr,actmp,info,b%a,rowscale=rowscale) + else + call psb_rwextd(nr,actmp,info,rowscale=rowscale) + end if + end if + if (info == psb_success_) call aa%mv_from_coo(actmp,info) + end select + end if + if (info /= psb_success_) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lzrwextd +subroutine psb_lzbase_rwextd(nr,a,info,b,rowscale) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lzbase_rwextd + implicit none + + ! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes) + integer(psb_lpk_), intent(in) :: nr + class(psb_lz_base_sparse_mat), intent(inout) :: a + integer(psb_ipk_),intent(out) :: info + class(psb_lz_base_sparse_mat), intent(in), optional :: b + logical,intent(in), optional :: rowscale + + integer(psb_lpk_) :: i,j,ja,jb,nza,nzb, ma, mb, na, nb + integer(psb_ipk_) :: err_act + character(len=20) :: name, ch_err + logical rowscale_ + + name='psb_lzbase_rwextd' + info = psb_success_ + call psb_erractionsave(err_act) + + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .true. + end if + + ma = a%get_nrows() + na = a%get_ncols() + + + select type(a) + type is (psb_lz_csr_sparse_mat) + + call psb_ensure_size(nr+1,a%irp,info) + + if (present(b)) then + mb = b%get_nrows() + nb = b%get_ncols() + nzb = b%get_nzeros() + + select type (b) + type is (psb_lz_csr_sparse_mat) + call psb_ensure_size(size(a%ja)+nzb,a%ja,info) + call psb_ensure_size(size(a%val)+nzb,a%val,info) + do i=1, min(nr-ma,mb) + a%irp(ma+i+1) = a%irp(ma+i) + b%irp(i+1) - b%irp(i) + ja = a%irp(ma+i) + do jb = b%irp(i), b%irp(i+1)-1 + a%val(ja) = b%val(jb) + a%ja(ja) = b%ja(jb) + ja = ja + 1 + end do + end do + do j=i,nr-ma + a%irp(ma+i+1) = a%irp(ma+i) + end do + class default + + write(psb_err_unit,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + end select + call a%set_ncols(max(na,nb)) + + else + + do i=ma+2,nr+1 + a%irp(i) = a%irp(i-1) + end do + + end if + + call a%set_nrows(nr) + + + type is (psb_lz_coo_sparse_mat) + nza = a%get_nzeros() + + if (present(b)) then + mb = b%get_nrows() + nb = b%get_ncols() + nzb = b%get_nzeros() + call a%reallocate(nza+nzb) + + select type(b) + type is (psb_lz_coo_sparse_mat) + + if (rowscale_) then + do j=1,nzb + if ((ma + b%ia(j)) <= nr) then + nza = nza + 1 + a%ia(nza) = ma + b%ia(j) + a%ja(nza) = b%ja(j) + a%val(nza) = b%val(j) + end if + enddo + else + do j=1,nzb + if ((ma + b%ia(j)) <= nr) then + nza = nza + 1 + a%ia(nza) = b%ia(j) + a%ja(nza) = b%ja(j) + a%val(nza) = b%val(j) + end if + enddo + endif + call a%set_nzeros(nza) + + type is (psb_lz_csr_sparse_mat) + + do i=1, min(nr-ma,mb) + do jb = b%irp(i), b%irp(i+1)-1 + nza = nza + 1 + a%val(nza) = b%val(jb) + a%ia(nza) = ma + i + a%ja(nza) = b%ja(jb) + end do + end do + call a%set_nzeros(nza) + + class default + write(psb_err_unit,*) 'Implement SPGETBLK in RWEXTD!!!!!!!' + + end select + + call a%set_ncols(max(na,nb)) + endif + + call a%set_nrows(nr) + + class default + info = psb_err_unsupported_format_ + ch_err=a%get_fmt() + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lzbase_rwextd diff --git a/base/serial/psb_zspspmm.f90 b/base/serial/psb_zspspmm.f90 index 13a7be87e..a1436ad17 100644 --- a/base/serial/psb_zspspmm.f90 +++ b/base/serial/psb_zspspmm.f90 @@ -115,3 +115,84 @@ subroutine psb_zspspmm(a,b,c,info) end subroutine psb_zspspmm + +subroutine psb_lzspspmm(a,b,c,info) + use psb_base_mod, psb_protect_name => psb_lzspspmm + implicit none + + type(psb_lzspmat_type), intent(in) :: a,b + type(psb_lzspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + type(psb_lz_csr_sparse_mat), allocatable :: ccsr + type(psb_lz_csc_sparse_mat), allocatable :: ccsc + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_spspmm' + logical :: done_spmm + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! + ! Shortcuts for special cases + ! + done_spmm = .false. + select type(aa=>a%a) + class is (psb_lz_csr_sparse_mat) + select type(ba=>b%a) + class is (psb_lz_csr_sparse_mat) + + allocate(ccsr,stat=info) + if (info == psb_success_) then + call psb_lzcsrspspmm(aa,ba,ccsr,info) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(ccsr,c%a) + done_spmm = .true. + + end select + + class is (psb_lz_csc_sparse_mat) + select type(ba=>b%a) + class is (psb_lz_csc_sparse_mat) + + allocate(ccsc,stat=info) + if (info == psb_success_) then + call psb_lzcscspspmm(aa,ba,ccsc,info) + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(ccsc,c%a) + done_spmm = .true. + + end select + + end select + + ! + ! General code + ! + if (.not.done_spmm) then + call psb_symbmm(a,b,c,info) + if (info == psb_success_) call psb_numbmm(a,b,c) + end if + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lzspspmm + diff --git a/base/serial/psb_zsymbmm.f90 b/base/serial/psb_zsymbmm.f90 index 67094aaf4..ada823264 100644 --- a/base/serial/psb_zsymbmm.f90 +++ b/base/serial/psb_zsymbmm.f90 @@ -255,3 +255,223 @@ contains end subroutine gen_symbmm end subroutine psb_zbase_symbmm + + + +subroutine psb_lzsymbmm(a,b,c,info) + use psb_base_mod, psb_protect_name => psb_lzsymbmm + implicit none + + type(psb_lzspmat_type), intent(in) :: a,b + type(psb_lzspmat_type), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + type(psb_lz_csr_sparse_mat), allocatable :: ccsr + integer(psb_ipk_) :: err_act + character(len=*), parameter :: name='psb_symbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + if ((a%is_null()) .or.(b%is_null())) then + info = psb_err_invalid_mat_state_ + call psb_errpush(info,name) + goto 9999 + endif + + allocate(ccsr,stat=info) + + if (info == psb_success_) then + call psb_symbmm(a%a,b%a,ccsr,info) + else + info = psb_err_alloc_dealloc_ + end if + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + call move_alloc(ccsr,c%a) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psb_lzsymbmm + +subroutine psb_lzbase_symbmm(a,b,c,info) + use psb_mat_mod + use psb_serial_mod, psb_protect_name => psb_lzbase_symbmm + implicit none + + class(psb_lz_base_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), allocatable :: itemp(:) + integer(psb_lpk_) :: nze, ma,na,mb,nb + character(len=20) :: name + integer(psb_ipk_) :: err_act + name='psb_symbmm' + call psb_erractionsave(err_act) + info = psb_success_ + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + + if ( mb /= na ) then + write(psb_err_unit,*) 'Mismatch in SYMBMM: ',ma,na,mb,nb + info = psb_err_invalid_matrix_sizes_ + call psb_errpush(info,name) + goto 9999 + endif + allocate(itemp(max(ma,na,mb,nb)),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_Errpush(info,name) + goto 9999 + endif + ! + ! Note: we need to test whether there is a performance impact + ! in not using the original Douglas & Bank code. + ! + select type(a) + type is (psb_lz_csr_sparse_mat) + select type(b) + type is (psb_lz_csr_sparse_mat) + call csr_symbmm(a,b,c,itemp,info) + class default + call gen_symbmm(a,b,c,itemp,info) + end select + class default + call gen_symbmm(a,b,c,itemp,info) + end select + + if (info /= psb_success_) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_realloc(size(c%ja),c%val,info) + deallocate(itemp) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + subroutine csr_symbmm(a,b,c,itemp,info) + type(psb_lz_csr_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_lpk_) :: itemp(:) + integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_) :: nze, ma,na,mb,nb + + info = psb_success_ + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = max(ma+1,2*ma) + call c%allocate(ma,nb,nze) + call lsymbmm(ma,na,nb,a%irp,a%ja,lzero,& + & b%irp,b%ja,lzero,& + & c%irp,c%ja,lzero,itemp) + + end subroutine csr_symbmm + subroutine gen_symbmm(a,b,c,index,info) + class(psb_lz_base_sparse_mat), intent(in) :: a,b + type(psb_lz_csr_sparse_mat), intent(out) :: c + integer(psb_lpk_) :: index(:) + integer(psb_ipk_) :: info + integer(psb_lpk_), allocatable :: iarw(:), iacl(:),ibrw(:),ibcl(:) + integer(psb_lpk_) :: maxlmn,i,j,m,n,k,l,istart,length,nazr,nbzr,jj,minlm,minmn + integer(psb_lpk_) :: nze, ma,na,mb,nb + + ma = a%get_nrows() + na = a%get_ncols() + mb = b%get_nrows() + nb = b%get_ncols() + + nze = max(ma+1,2*ma) + call c%allocate(ma,nb,nze) + + n = ma + m = na + l = nb + maxlmn = max(l,m,n) + + allocate(iarw(maxlmn),iacl(maxlmn),ibrw(maxlmn),ibcl(maxlmn),& + & stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + return + endif + + do i=1,maxlmn + index(i)=0 + end do + + c%irp(1)=1 + minlm = min(l,m) + minmn = min(m,n) + + main: do i=1,n + istart=-1 + length=0 + call a%csget(i,i,nazr,iarw,iacl,info) + do jj=1, nazr + + j=iacl(jj) + + if ((j<1).or.(j>m)) then + write(psb_err_unit,*) ' SymbMM: Problem with A ',i,jj,j,m + info = 1 + return + endif + call b%csget(j,j,nbzr,ibrw,ibcl,info) + do k=1,nbzr + if ((ibcl(k)<1).or.(ibcl(k)>maxlmn)) then + write(psb_err_unit,*) 'Problem in SYMBMM 1:',j,k,ibcl(k),maxlmn + info=psb_err_pivot_too_small_ + return + else + if(index(ibcl(k)) == 0) then + index(ibcl(k))=istart + istart=ibcl(k) + length=length+1 + endif + endif + end do + end do + + c%irp(i+1)=c%irp(i)+length + + if (c%irp(i+1) > size(c%ja)) then + if (n > (2*i)) then + nze = max(c%irp(i+1), c%irp(i)*((n+i-1)/i)) + else + nze = max(c%irp(i+1), nint((dble(c%irp(i))*(dble(n)/i))) ) + endif + call psb_realloc(nze,c%ja,info) + end if + do j= c%irp(i),c%irp(i+1)-1 + c%ja(j)=istart + istart=index(istart) + index(c%ja(j))=0 + end do + call psb_msort(c%ja(c%irp(i):c%irp(i)+length-1)) + index(i) = 0 + end do main + + end subroutine gen_symbmm + +end subroutine psb_lzbase_symbmm diff --git a/base/serial/psi_c_serial_impl.f90 b/base/serial/psi_c_serial_impl.f90 index 4794c38e6..77841b762 100644 --- a/base/serial/psi_c_serial_impl.f90 +++ b/base/serial/psi_c_serial_impl.f90 @@ -45,9 +45,11 @@ subroutine psi_caxpby(m,n,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ @@ -102,9 +104,11 @@ subroutine psi_caxpbyv(m,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ diff --git a/base/serial/psi_d_serial_impl.f90 b/base/serial/psi_d_serial_impl.f90 index 71f62cd57..0e1904f1e 100644 --- a/base/serial/psi_d_serial_impl.f90 +++ b/base/serial/psi_d_serial_impl.f90 @@ -45,9 +45,11 @@ subroutine psi_daxpby(m,n,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ @@ -102,9 +104,11 @@ subroutine psi_daxpbyv(m,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ diff --git a/base/serial/psi_i_serial_impl.f90 b/base/serial/psi_e_serial_impl.f90 similarity index 76% rename from base/serial/psi_i_serial_impl.f90 rename to base/serial/psi_e_serial_impl.f90 index 90d2cdeaa..9f1986511 100644 --- a/base/serial/psi_i_serial_impl.f90 +++ b/base/serial/psi_e_serial_impl.f90 @@ -29,15 +29,15 @@ ! POSSIBILITY OF SUCH DAMAGE. ! ! -subroutine psi_iaxpby(m,n,alpha, x, beta, y, info) +subroutine psi_eaxpby(m,n,alpha, x, beta, y, info) use psb_const_mod use psb_error_mod implicit none integer(psb_ipk_), intent(in) :: m, n - integer(psb_ipk_), intent (in) :: x(:,:) - integer(psb_ipk_), intent (inout) :: y(:,:) - integer(psb_ipk_), intent (in) :: alpha, beta + integer(psb_epk_), intent (in) :: x(:,:) + integer(psb_epk_), intent (inout) :: y(:,:) + integer(psb_epk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: lx, ly @@ -45,9 +45,11 @@ subroutine psi_iaxpby(m,n,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ @@ -76,7 +78,7 @@ subroutine psi_iaxpby(m,n,alpha, x, beta, y, info) goto 9999 end if - if ((m>0).and.(n>0)) call iaxpby(m,n,alpha,x,lx,beta,y,ly,info) + if ((m>0).and.(n>0)) call eaxpby(m,n,alpha,x,lx,beta,y,ly,info) call psb_erractionrestore(err_act) return @@ -84,17 +86,17 @@ subroutine psi_iaxpby(m,n,alpha, x, beta, y, info) 9999 call psb_error_handler(err_act) return -end subroutine psi_iaxpby +end subroutine psi_eaxpby -subroutine psi_iaxpbyv(m,alpha, x, beta, y, info) +subroutine psi_eaxpbyv(m,alpha, x, beta, y, info) use psb_const_mod use psb_error_mod implicit none integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent (in) :: x(:) - integer(psb_ipk_), intent (inout) :: y(:) - integer(psb_ipk_), intent (in) :: alpha, beta + integer(psb_epk_), intent (in) :: x(:) + integer(psb_epk_), intent (inout) :: y(:) + integer(psb_epk_), intent (in) :: alpha, beta integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: lx, ly @@ -102,9 +104,11 @@ subroutine psi_iaxpbyv(m,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ @@ -127,7 +131,7 @@ subroutine psi_iaxpbyv(m,alpha, x, beta, y, info) goto 9999 end if - if (m>0) call iaxpby(m,ione,alpha,x,lx,beta,y,ly,info) + if (m>0) call eaxpby(m,ione,alpha,x,lx,beta,y,ly,info) call psb_erractionrestore(err_act) return @@ -136,30 +140,30 @@ subroutine psi_iaxpbyv(m,alpha, x, beta, y, info) return -end subroutine psi_iaxpbyv +end subroutine psi_eaxpbyv -subroutine psi_igthmv(n,k,idx,alpha,x,beta,y) +subroutine psi_egthmv(n,k,idx,alpha,x,beta,y) use psb_const_mod implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: x(:,:), y(:),alpha,beta + integer(psb_epk_) :: x(:,:), y(:),alpha,beta ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == izero) then - if (alpha == izero) then + if (beta == ezero) then + if (alpha == ezero) then pt=0 do j=1,k do i=1,n pt=pt+1 - y(pt) = izero + y(pt) = ezero end do end do - else if (alpha == ione) then + else if (alpha == eone) then pt=0 do j=1,k do i=1,n @@ -167,7 +171,7 @@ subroutine psi_igthmv(n,k,idx,alpha,x,beta,y) y(pt) = x(idx(i),j) end do end do - else if (alpha == -ione) then + else if (alpha == -eone) then pt=0 do j=1,k do i=1,n @@ -185,17 +189,17 @@ subroutine psi_igthmv(n,k,idx,alpha,x,beta,y) end do end if else - if (beta == ione) then + if (beta == eone) then ! Do nothing - else if (beta == -ione) then + else if (beta == -eone) then y(1:n*k) = -y(1:n*k) else y(1:n*k) = beta*y(1:n*k) end if - if (alpha == izero) then + if (alpha == ezero) then ! do nothing - else if (alpha == ione) then + else if (alpha == eone) then pt=0 do j=1,k do i=1,n @@ -203,7 +207,7 @@ subroutine psi_igthmv(n,k,idx,alpha,x,beta,y) y(pt) = y(pt) + x(idx(i),j) end do end do - else if (alpha == -ione) then + else if (alpha == -eone) then pt=0 do j=1,k do i=1,n @@ -222,28 +226,28 @@ subroutine psi_igthmv(n,k,idx,alpha,x,beta,y) end if end if -end subroutine psi_igthmv +end subroutine psi_egthmv -subroutine psi_igthv(n,idx,alpha,x,beta,y) +subroutine psi_egthv(n,idx,alpha,x,beta,y) use psb_const_mod implicit none integer(psb_ipk_) :: n, idx(:) - integer(psb_ipk_) :: x(:), y(:),alpha,beta + integer(psb_epk_) :: x(:), y(:),alpha,beta ! Locals integer(psb_ipk_) :: i - if (beta == izero) then - if (alpha == izero) then + if (beta == ezero) then + if (alpha == ezero) then do i=1,n - y(i) = izero + y(i) = ezero end do - else if (alpha == ione) then + else if (alpha == eone) then do i=1,n y(i) = x(idx(i)) end do - else if (alpha == -ione) then + else if (alpha == -eone) then do i=1,n y(i) = -x(idx(i)) end do @@ -253,21 +257,21 @@ subroutine psi_igthv(n,idx,alpha,x,beta,y) end do end if else - if (beta == ione) then + if (beta == eone) then ! Do nothing - else if (beta == -ione) then + else if (beta == -eone) then y(1:n) = -y(1:n) else y(1:n) = beta*y(1:n) end if - if (alpha == izero) then + if (alpha == ezero) then ! do nothing - else if (alpha == ione) then + else if (alpha == eone) then do i=1,n y(i) = y(i) + x(idx(i)) end do - else if (alpha == -ione) then + else if (alpha == -eone) then do i=1,n y(i) = y(i) - x(idx(i)) end do @@ -278,15 +282,15 @@ subroutine psi_igthv(n,idx,alpha,x,beta,y) end if end if -end subroutine psi_igthv +end subroutine psi_egthv -subroutine psi_igthzmm(n,k,idx,x,y) +subroutine psi_egthzmm(n,k,idx,x,y) use psb_const_mod implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: x(:,:), y(:,:) + integer(psb_epk_) :: x(:,:), y(:,:) ! Locals integer(psb_ipk_) :: i @@ -296,15 +300,15 @@ subroutine psi_igthzmm(n,k,idx,x,y) y(i,1:k)=x(idx(i),1:k) end do -end subroutine psi_igthzmm +end subroutine psi_egthzmm -subroutine psi_igthzmv(n,k,idx,x,y) +subroutine psi_egthzmv(n,k,idx,x,y) use psb_const_mod implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: x(:,:), y(:) + integer(psb_epk_) :: x(:,:), y(:) ! Locals integer(psb_ipk_) :: i, j, pt @@ -317,15 +321,15 @@ subroutine psi_igthzmv(n,k,idx,x,y) end do end do -end subroutine psi_igthzmv +end subroutine psi_egthzmv -subroutine psi_igthzv(n,idx,x,y) +subroutine psi_egthzv(n,idx,x,y) use psb_const_mod implicit none integer(psb_ipk_) :: n, idx(:) - integer(psb_ipk_) :: x(:), y(:) + integer(psb_epk_) :: x(:), y(:) ! Locals integer(psb_ipk_) :: i @@ -334,24 +338,24 @@ subroutine psi_igthzv(n,idx,x,y) y(i)=x(idx(i)) end do -end subroutine psi_igthzv +end subroutine psi_egthzv -subroutine psi_isctmm(n,k,idx,x,beta,y) +subroutine psi_esctmm(n,k,idx,x,beta,y) use psb_const_mod implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: beta, x(:,:), y(:,:) + integer(psb_epk_) :: beta, x(:,:), y(:,:) ! Locals integer(psb_ipk_) :: i, j - if (beta == izero) then + if (beta == ezero) then do i=1,n y(idx(i),1:k) = x(i,1:k) end do - else if (beta == ione) then + else if (beta == eone) then do i=1,n y(idx(i),1:k) = y(idx(i),1:k)+x(i,1:k) end do @@ -360,20 +364,20 @@ subroutine psi_isctmm(n,k,idx,x,beta,y) y(idx(i),1:k) = beta*y(idx(i),1:k)+x(i,1:k) end do end if -end subroutine psi_isctmm +end subroutine psi_esctmm -subroutine psi_isctmv(n,k,idx,x,beta,y) +subroutine psi_esctmv(n,k,idx,x,beta,y) use psb_const_mod implicit none integer(psb_ipk_) :: n, k, idx(:) - integer(psb_ipk_) :: beta, x(:), y(:,:) + integer(psb_epk_) :: beta, x(:), y(:,:) ! Locals integer(psb_ipk_) :: i, j, pt - if (beta == izero) then + if (beta == ezero) then pt=0 do j=1,k do i=1,n @@ -381,7 +385,7 @@ subroutine psi_isctmv(n,k,idx,x,beta,y) y(idx(i),j) = x(pt) end do end do - else if (beta == ione) then + else if (beta == eone) then pt=0 do j=1,k do i=1,n @@ -398,24 +402,24 @@ subroutine psi_isctmv(n,k,idx,x,beta,y) end do end do end if -end subroutine psi_isctmv +end subroutine psi_esctmv -subroutine psi_isctv(n,idx,x,beta,y) +subroutine psi_esctv(n,idx,x,beta,y) use psb_const_mod implicit none integer(psb_ipk_) :: n, idx(:) - integer(psb_ipk_) :: beta, x(:), y(:) + integer(psb_epk_) :: beta, x(:), y(:) ! Locals integer(psb_ipk_) :: i - if (beta == izero) then + if (beta == ezero) then do i=1,n y(idx(i)) = x(i) end do - else if (beta == ione) then + else if (beta == eone) then do i=1,n y(idx(i)) = y(idx(i))+x(i) end do @@ -424,19 +428,19 @@ subroutine psi_isctv(n,idx,x,beta,y) y(idx(i)) = beta*y(idx(i))+x(i) end do end if -end subroutine psi_isctv +end subroutine psi_esctv -subroutine iaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) +subroutine eaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) use psb_const_mod use psb_error_mod implicit none integer(psb_ipk_) :: n, m, lldx, lldy, info - integer(psb_ipk_) X(lldx,*), Y(lldy,*) - integer(psb_ipk_) alpha, beta + integer(psb_epk_) X(lldx,*), Y(lldy,*) + integer(psb_epk_) alpha, beta integer(psb_ipk_) :: i, j integer(psb_ipk_) :: int_err(5) character name*20 - name='iaxpby' + name='eaxpby' ! @@ -473,19 +477,19 @@ subroutine iaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) goto 9999 endif - if (alpha.eq.izero) then - if (beta.eq.izero) then + if (alpha.eq.ezero) then + if (beta.eq.ezero) then do j=1, n do i=1,m - y(i,j) = izero + y(i,j) = ezero enddo enddo - else if (beta.eq.ione) then + else if (beta.eq.eone) then ! ! Do nothing! ! - else if (beta.eq.-ione) then + else if (beta.eq.-eone) then do j=1,n do i=1,m y(i,j) = - y(i,j) @@ -499,22 +503,22 @@ subroutine iaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) enddo endif - else if (alpha.eq.ione) then + else if (alpha.eq.eone) then - if (beta.eq.izero) then + if (beta.eq.ezero) then do j=1,n do i=1,m y(i,j) = x(i,j) enddo enddo - else if (beta.eq.ione) then + else if (beta.eq.eone) then do j=1,n do i=1,m y(i,j) = x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-ione) then + else if (beta.eq.-eone) then do j=1,n do i=1,m y(i,j) = x(i,j) - y(i,j) @@ -528,22 +532,22 @@ subroutine iaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) enddo endif - else if (alpha.eq.-ione) then + else if (alpha.eq.-eone) then - if (beta.eq.izero) then + if (beta.eq.ezero) then do j=1,n do i=1,m y(i,j) = -x(i,j) enddo enddo - else if (beta.eq.ione) then + else if (beta.eq.eone) then do j=1,n do i=1,m y(i,j) = -x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-ione) then + else if (beta.eq.-eone) then do j=1,n do i=1,m y(i,j) = -x(i,j) - y(i,j) @@ -559,20 +563,20 @@ subroutine iaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) else - if (beta.eq.izero) then + if (beta.eq.ezero) then do j=1,n do i=1,m y(i,j) = alpha*x(i,j) enddo enddo - else if (beta.eq.ione) then + else if (beta.eq.eone) then do j=1,n do i=1,m y(i,j) = alpha*x(i,j) + y(i,j) enddo enddo - else if (beta.eq.-ione) then + else if (beta.eq.-eone) then do j=1,n do i=1,m y(i,j) = alpha*x(i,j) - y(i,j) @@ -594,4 +598,4 @@ subroutine iaxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) call fcpsb_serror() return -end subroutine iaxpby +end subroutine eaxpby diff --git a/base/serial/psi_m_serial_impl.f90 b/base/serial/psi_m_serial_impl.f90 new file mode 100644 index 000000000..a885f2bd6 --- /dev/null +++ b/base/serial/psi_m_serial_impl.f90 @@ -0,0 +1,601 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +subroutine psi_maxpby(m,n,alpha, x, beta, y, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m, n + integer(psb_mpk_), intent (in) :: x(:,:) + integer(psb_mpk_), intent (inout) :: y(:,:) + integer(psb_mpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (n < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 2; ierr(2) = n + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 4; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 6; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if ((m>0).and.(n>0)) call maxpby(m,n,alpha,x,lx,beta,y,ly,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psi_maxpby + +subroutine psi_maxpbyv(m,alpha, x, beta, y, info) + + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_), intent(in) :: m + integer(psb_mpk_), intent (in) :: x(:) + integer(psb_mpk_), intent (inout) :: y(:) + integer(psb_mpk_), intent (in) :: alpha, beta + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: lx, ly + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name, ch_err + + name='psb_geaxpby' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (m < 0) then + info = psb_err_iarg_neg_ + ierr(1) = 1; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + lx = size(x,1) + ly = size(y,1) + if (lx < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 3; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + if (ly < m) then + info = psb_err_input_asize_small_i_ + ierr(1) = 5; ierr(2) = m + call psb_errpush(info,name,i_err=ierr) + goto 9999 + end if + + if (m>0) call maxpby(m,ione,alpha,x,lx,beta,y,ly,info) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine psi_maxpbyv + + +subroutine psi_mgthmv(n,k,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: x(:,:), y(:),alpha,beta + + ! Locals + integer(psb_ipk_) :: i, j, pt + + if (beta == mzero) then + if (alpha == mzero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = mzero + end do + end do + else if (alpha == mone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = x(idx(i),j) + end do + end do + else if (alpha == -mone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = -x(idx(i),j) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = alpha*x(idx(i),j) + end do + end do + end if + else + if (beta == mone) then + ! Do nothing + else if (beta == -mone) then + y(1:n*k) = -y(1:n*k) + else + y(1:n*k) = beta*y(1:n*k) + end if + + if (alpha == mzero) then + ! do nothing + else if (alpha == mone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = y(pt) + x(idx(i),j) + end do + end do + else if (alpha == -mone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = y(pt) - x(idx(i),j) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt) = y(pt) + alpha*x(idx(i),j) + end do + end do + end if + end if + +end subroutine psi_mgthmv + +subroutine psi_mgthv(n,idx,alpha,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, idx(:) + integer(psb_mpk_) :: x(:), y(:),alpha,beta + + ! Locals + integer(psb_ipk_) :: i + if (beta == mzero) then + if (alpha == mzero) then + do i=1,n + y(i) = mzero + end do + else if (alpha == mone) then + do i=1,n + y(i) = x(idx(i)) + end do + else if (alpha == -mone) then + do i=1,n + y(i) = -x(idx(i)) + end do + else + do i=1,n + y(i) = alpha*x(idx(i)) + end do + end if + else + if (beta == mone) then + ! Do nothing + else if (beta == -mone) then + y(1:n) = -y(1:n) + else + y(1:n) = beta*y(1:n) + end if + + if (alpha == mzero) then + ! do nothing + else if (alpha == mone) then + do i=1,n + y(i) = y(i) + x(idx(i)) + end do + else if (alpha == -mone) then + do i=1,n + y(i) = y(i) - x(idx(i)) + end do + else + do i=1,n + y(i) = y(i) + alpha*x(idx(i)) + end do + end if + end if + +end subroutine psi_mgthv + +subroutine psi_mgthzmm(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i + + + do i=1,n + y(i,1:k)=x(idx(i),1:k) + end do + +end subroutine psi_mgthzmm + +subroutine psi_mgthzmv(n,k,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: x(:,:), y(:) + + ! Locals + integer(psb_ipk_) :: i, j, pt + + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(pt)=x(idx(i),j) + end do + end do + +end subroutine psi_mgthzmv + +subroutine psi_mgthzv(n,idx,x,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, idx(:) + integer(psb_mpk_) :: x(:), y(:) + + ! Locals + integer(psb_ipk_) :: i + + do i=1,n + y(i)=x(idx(i)) + end do + +end subroutine psi_mgthzv + +subroutine psi_msctmm(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: beta, x(:,:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j + + if (beta == mzero) then + do i=1,n + y(idx(i),1:k) = x(i,1:k) + end do + else if (beta == mone) then + do i=1,n + y(idx(i),1:k) = y(idx(i),1:k)+x(i,1:k) + end do + else + do i=1,n + y(idx(i),1:k) = beta*y(idx(i),1:k)+x(i,1:k) + end do + end if +end subroutine psi_msctmm + +subroutine psi_msctmv(n,k,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, k, idx(:) + integer(psb_mpk_) :: beta, x(:), y(:,:) + + ! Locals + integer(psb_ipk_) :: i, j, pt + + if (beta == mzero) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = x(pt) + end do + end do + else if (beta == mone) then + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = y(idx(i),j)+x(pt) + end do + end do + else + pt=0 + do j=1,k + do i=1,n + pt=pt+1 + y(idx(i),j) = beta*y(idx(i),j)+x(pt) + end do + end do + end if +end subroutine psi_msctmv + +subroutine psi_msctv(n,idx,x,beta,y) + + use psb_const_mod + implicit none + + integer(psb_ipk_) :: n, idx(:) + integer(psb_mpk_) :: beta, x(:), y(:) + + ! Locals + integer(psb_ipk_) :: i + + if (beta == mzero) then + do i=1,n + y(idx(i)) = x(i) + end do + else if (beta == mone) then + do i=1,n + y(idx(i)) = y(idx(i))+x(i) + end do + else + do i=1,n + y(idx(i)) = beta*y(idx(i))+x(i) + end do + end if +end subroutine psi_msctv + +subroutine maxpby(m, n, alpha, X, lldx, beta, Y, lldy, info) + use psb_const_mod + use psb_error_mod + implicit none + integer(psb_ipk_) :: n, m, lldx, lldy, info + integer(psb_mpk_) X(lldx,*), Y(lldy,*) + integer(psb_mpk_) alpha, beta + integer(psb_ipk_) :: i, j + integer(psb_ipk_) :: int_err(5) + character name*20 + name='maxpby' + + + ! + ! Error handling + ! + info = psb_success_ + if (m.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (n.lt.0) then + info=psb_err_iarg_neg_ + int_err(1)=1 + int_err(2)=n + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldx.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=5 + int_err(2)=1 + int_err(3)=lldx + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + else if (lldy.lt.max(1,m)) then + info=psb_err_iarg_not_gtia_ii_ + int_err(1)=8 + int_err(2)=1 + int_err(3)=lldy + int_err(4)=m + call fcpsb_errpush(info,name,int_err) + goto 9999 + endif + + if (alpha.eq.mzero) then + if (beta.eq.mzero) then + do j=1, n + do i=1,m + y(i,j) = mzero + enddo + enddo + else if (beta.eq.mone) then + ! + ! Do nothing! + ! + + else if (beta.eq.-mone) then + do j=1,n + do i=1,m + y(i,j) = - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.mone) then + + if (beta.eq.mzero) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + enddo + enddo + else if (beta.eq.mone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-mone) then + do j=1,n + do i=1,m + y(i,j) = x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else if (alpha.eq.-mone) then + + if (beta.eq.mzero) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + enddo + enddo + else if (beta.eq.mone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-mone) then + do j=1,n + do i=1,m + y(i,j) = -x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = -x(i,j) + beta*y(i,j) + enddo + enddo + endif + + else + + if (beta.eq.mzero) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + enddo + enddo + else if (beta.eq.mone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + y(i,j) + enddo + enddo + + else if (beta.eq.-mone) then + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) - y(i,j) + enddo + enddo + else + do j=1,n + do i=1,m + y(i,j) = alpha*x(i,j) + beta*y(i,j) + enddo + enddo + endif + + endif + + return + +9999 continue + call fcpsb_serror() + return + +end subroutine maxpby diff --git a/base/serial/psi_s_serial_impl.f90 b/base/serial/psi_s_serial_impl.f90 index cba561283..f9b837279 100644 --- a/base/serial/psi_s_serial_impl.f90 +++ b/base/serial/psi_s_serial_impl.f90 @@ -45,9 +45,11 @@ subroutine psi_saxpby(m,n,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ @@ -102,9 +104,11 @@ subroutine psi_saxpbyv(m,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ diff --git a/base/serial/psi_z_serial_impl.f90 b/base/serial/psi_z_serial_impl.f90 index 9444f6c52..8d9454304 100644 --- a/base/serial/psi_z_serial_impl.f90 +++ b/base/serial/psi_z_serial_impl.f90 @@ -45,9 +45,11 @@ subroutine psi_zaxpby(m,n,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ @@ -102,9 +104,11 @@ subroutine psi_zaxpbyv(m,alpha, x, beta, y, info) character(len=20) :: name, ch_err name='psb_geaxpby' - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (m < 0) then info = psb_err_iarg_neg_ diff --git a/base/serial/sort/Makefile b/base/serial/sort/Makefile index 4dc7435a2..c381e3f50 100644 --- a/base/serial/sort/Makefile +++ b/base/serial/sort/Makefile @@ -4,13 +4,14 @@ include ../../../Make.inc # The object files # BOBJS=psi_lcx_mod.o psi_alcx_mod.o psi_acx_mod.o -IOBJS=psb_i_hsort_impl.o psb_i_isort_impl.o psb_i_msort_impl.o psb_i_qsort_impl.o +IOBJS=psb_m_hsort_impl.o psb_m_isort_impl.o psb_m_msort_impl.o psb_m_qsort_impl.o +LOBJS=psb_e_hsort_impl.o psb_e_isort_impl.o psb_e_msort_impl.o psb_e_qsort_impl.o SOBJS=psb_s_hsort_impl.o psb_s_isort_impl.o psb_s_msort_impl.o psb_s_qsort_impl.o DOBJS=psb_d_hsort_impl.o psb_d_isort_impl.o psb_d_msort_impl.o psb_d_qsort_impl.o COBJS=psb_c_hsort_impl.o psb_c_isort_impl.o psb_c_msort_impl.o psb_c_qsort_impl.o ZOBJS=psb_z_hsort_impl.o psb_z_isort_impl.o psb_z_msort_impl.o psb_z_qsort_impl.o -OBJS=$(BOBJS) $(IOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) +OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS) $(IOBJS) $(LOBJS) # # Where the library should go, and how it is called. @@ -34,7 +35,7 @@ lib: $(OBJS) # A bit excessive, but safe $(OBJS): $(MODDIR)/psb_base_mod.o -$(IOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS): $(BOBJS) +$(IOBJS) $(LOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS): $(BOBJS) clean: cleanobjs veryclean: cleanobjs diff --git a/base/serial/sort/psb_c_hsort_impl.f90 b/base/serial/sort/psb_c_hsort_impl.f90 index 499dce043..8a5fe3c71 100644 --- a/base/serial/sort/psb_c_hsort_impl.f90 +++ b/base/serial/sort/psb_c_hsort_impl.f90 @@ -42,7 +42,7 @@ ! Addison-Wesley ! subroutine psb_chsort(x,ix,dir,flag) - use psb_c_sort_mod, psb_protect_name => psb_chsort + use psb_sort_mod, psb_protect_name => psb_chsort use psb_error_mod implicit none complex(psb_spk_), intent(inout) :: x(:) @@ -116,13 +116,13 @@ subroutine psb_chsort(x,ix,dir,flag) do i=1, n key = x(i) index = ix(i) - call psi_c_idx_insert_heap(key,index,l,x,ix,dir_,info) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ' end if end do do i=n, 2, -1 - call psi_c_idx_heap_get_first(key,index,l,x,ix,dir_,info) + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) if (l /= i-1) then write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i end if @@ -133,7 +133,7 @@ subroutine psb_chsort(x,ix,dir,flag) l = 0 do i=1, n key = x(i) - call psi_c_insert_heap(key,l,x,dir_,info) + call psi_insert_heap(key,l,x,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i end if @@ -185,7 +185,7 @@ end subroutine psb_chsort ! subroutine psi_c_insert_heap(key,last,heap,dir,info) - use psb_c_sort_mod, psb_protect_name => psi_c_insert_heap + use psb_sort_mod, psb_protect_name => psi_c_insert_heap implicit none ! @@ -391,7 +391,7 @@ contains end subroutine psi_c_insert_heap subroutine psi_c_heap_get_first(key,last,heap,dir,info) - use psb_c_sort_mod, psb_protect_name => psi_c_heap_get_first + use psb_sort_mod, psb_protect_name => psi_c_heap_get_first implicit none ! @@ -633,7 +633,7 @@ contains end subroutine psi_c_heap_get_first subroutine psi_c_idx_insert_heap(key,index,last,heap,idxs,dir,info) - use psb_c_sort_mod, psb_protect_name => psi_c_idx_insert_heap + use psb_sort_mod, psb_protect_name => psi_c_idx_insert_heap implicit none ! @@ -869,7 +869,7 @@ end subroutine psi_c_idx_insert_heap subroutine psi_c_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - use psb_c_sort_mod, psb_protect_name => psi_c_idx_heap_get_first + use psb_sort_mod, psb_protect_name => psi_c_idx_heap_get_first implicit none ! diff --git a/base/serial/sort/psb_c_isort_impl.f90 b/base/serial/sort/psb_c_isort_impl.f90 index f5b7f9740..e61637533 100644 --- a/base/serial/sort/psb_c_isort_impl.f90 +++ b/base/serial/sort/psb_c_isort_impl.f90 @@ -41,14 +41,15 @@ ! Addison-Wesley ! subroutine psb_cisort(x,ix,dir,flag) - use psb_c_sort_mod, psb_protect_name => psb_cisort + use psb_sort_mod, psb_protect_name => psb_cisort use psb_error_mod implicit none complex(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i + integer(psb_ipk_) :: dir_, flag_, err_act + integer(psb_ipk_) :: n, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -138,7 +139,7 @@ subroutine psb_cisort(x,ix,dir,flag) end subroutine psb_cisort subroutine psi_clisrx_up(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_clisrx_up + use psb_sort_mod, psb_protect_name => psi_clisrx_up use psb_error_mod use psi_lcx_mod implicit none @@ -168,7 +169,7 @@ subroutine psi_clisrx_up(n,x,idx) end subroutine psi_clisrx_up subroutine psi_clisrx_dw(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_clisrx_dw + use psb_sort_mod, psb_protect_name => psi_clisrx_dw use psb_error_mod use psi_lcx_mod implicit none @@ -197,7 +198,7 @@ subroutine psi_clisrx_dw(n,x,idx) end subroutine psi_clisrx_dw subroutine psi_clisr_up(n,x) - use psb_c_sort_mod, psb_protect_name => psi_clisr_up + use psb_sort_mod, psb_protect_name => psi_clisr_up use psb_error_mod use psi_lcx_mod implicit none @@ -222,7 +223,7 @@ subroutine psi_clisr_up(n,x) end subroutine psi_clisr_up subroutine psi_clisr_dw(n,x) - use psb_c_sort_mod, psb_protect_name => psi_clisr_dw + use psb_sort_mod, psb_protect_name => psi_clisr_dw use psb_error_mod use psi_lcx_mod implicit none @@ -247,7 +248,7 @@ subroutine psi_clisr_dw(n,x) end subroutine psi_clisr_dw subroutine psi_calisrx_up(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_calisrx_up + use psb_sort_mod, psb_protect_name => psi_calisrx_up use psb_error_mod use psi_alcx_mod implicit none @@ -276,7 +277,7 @@ subroutine psi_calisrx_up(n,x,idx) end subroutine psi_calisrx_up subroutine psi_calisrx_dw(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_calisrx_dw + use psb_sort_mod, psb_protect_name => psi_calisrx_dw use psb_error_mod use psi_alcx_mod implicit none @@ -305,7 +306,7 @@ subroutine psi_calisrx_dw(n,x,idx) end subroutine psi_calisrx_dw subroutine psi_calisr_up(n,x) - use psb_c_sort_mod, psb_protect_name => psi_calisr_up + use psb_sort_mod, psb_protect_name => psi_calisr_up use psb_error_mod use psi_alcx_mod implicit none @@ -330,7 +331,7 @@ subroutine psi_calisr_up(n,x) end subroutine psi_calisr_up subroutine psi_calisr_dw(n,x) - use psb_c_sort_mod, psb_protect_name => psi_calisr_dw + use psb_sort_mod, psb_protect_name => psi_calisr_dw use psb_error_mod use psi_alcx_mod implicit none @@ -355,7 +356,7 @@ subroutine psi_calisr_dw(n,x) end subroutine psi_calisr_dw subroutine psi_caisrx_up(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_caisrx_up + use psb_sort_mod, psb_protect_name => psi_caisrx_up use psb_error_mod implicit none complex(psb_spk_), intent(inout) :: x(:) @@ -383,7 +384,7 @@ subroutine psi_caisrx_up(n,x,idx) end subroutine psi_caisrx_up subroutine psi_caisrx_dw(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_caisrx_dw + use psb_sort_mod, psb_protect_name => psi_caisrx_dw use psb_error_mod implicit none complex(psb_spk_), intent(inout) :: x(:) @@ -411,7 +412,7 @@ subroutine psi_caisrx_dw(n,x,idx) end subroutine psi_caisrx_dw subroutine psi_caisr_up(n,x) - use psb_c_sort_mod, psb_protect_name => psi_caisr_up + use psb_sort_mod, psb_protect_name => psi_caisr_up use psb_error_mod implicit none complex(psb_spk_), intent(inout) :: x(:) @@ -435,7 +436,7 @@ subroutine psi_caisr_up(n,x) end subroutine psi_caisr_up subroutine psi_caisr_dw(n,x) - use psb_c_sort_mod, psb_protect_name => psi_caisr_dw + use psb_sort_mod, psb_protect_name => psi_caisr_dw use psb_error_mod implicit none complex(psb_spk_), intent(inout) :: x(:) diff --git a/base/serial/sort/psb_c_msort_impl.f90 b/base/serial/sort/psb_c_msort_impl.f90 index c41cb9c82..fa87a4259 100644 --- a/base/serial/sort/psb_c_msort_impl.f90 +++ b/base/serial/sort/psb_c_msort_impl.f90 @@ -42,7 +42,7 @@ ! subroutine psb_cmsort_u(x,nout,dir) - use psb_c_sort_mod, psb_protect_name => psb_cmsort_u + use psb_sort_mod, psb_protect_name => psb_cmsort_u use psb_error_mod implicit none complex(psb_spk_), intent(inout) :: x(:) @@ -84,7 +84,7 @@ subroutine psb_cmsort(x,ix,dir,flag) - use psb_c_sort_mod, psb_protect_name => psb_cmsort + use psb_sort_mod, psb_protect_name => psb_cmsort use psb_error_mod use psb_ip_reord_mod implicit none diff --git a/base/serial/sort/psb_c_qsort_impl.f90 b/base/serial/sort/psb_c_qsort_impl.f90 index f22f3a862..712529fc7 100644 --- a/base/serial/sort/psb_c_qsort_impl.f90 +++ b/base/serial/sort/psb_c_qsort_impl.f90 @@ -41,15 +41,15 @@ ! Addison-Wesley ! subroutine psb_cqsort(x,ix,dir,flag) - use psb_c_sort_mod, psb_protect_name => psb_cqsort + use psb_sort_mod, psb_protect_name => psb_cqsort use psb_error_mod implicit none complex(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i - + integer(psb_ipk_) :: dir_, flag_, err_act, i + integer(psb_ipk_) :: n integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -139,7 +139,7 @@ end subroutine psb_cqsort subroutine psi_clqsrx_up(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_clqsrx_up + use psb_sort_mod, psb_protect_name => psi_clqsrx_up use psb_error_mod use psi_lcx_mod implicit none @@ -150,7 +150,8 @@ subroutine psi_clqsrx_up(n,x,idx) ! .. Local Scalars .. complex(psb_spk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=32 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -295,7 +296,7 @@ subroutine psi_clqsrx_up(n,x,idx) end subroutine psi_clqsrx_up subroutine psi_clqsrx_dw(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_clqsrx_dw + use psb_sort_mod, psb_protect_name => psi_clqsrx_dw use psb_error_mod use psi_lcx_mod implicit none @@ -306,7 +307,8 @@ subroutine psi_clqsrx_dw(n,x,idx) ! .. Local Scalars .. complex(psb_spk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=32 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -450,7 +452,7 @@ subroutine psi_clqsrx_dw(n,x,idx) end subroutine psi_clqsrx_dw subroutine psi_clqsr_up(n,x) - use psb_c_sort_mod, psb_protect_name => psi_clqsr_up + use psb_sort_mod, psb_protect_name => psi_clqsr_up use psb_error_mod use psi_lcx_mod implicit none @@ -592,7 +594,7 @@ subroutine psi_clqsr_up(n,x) end subroutine psi_clqsr_up subroutine psi_clqsr_dw(n,x) - use psb_c_sort_mod, psb_protect_name => psi_clqsr_dw + use psb_sort_mod, psb_protect_name => psi_clqsr_dw use psb_error_mod use psi_lcx_mod implicit none @@ -733,7 +735,7 @@ subroutine psi_clqsr_dw(n,x) end subroutine psi_clqsr_dw subroutine psi_calqsrx_up(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_calqsrx_up + use psb_sort_mod, psb_protect_name => psi_calqsrx_up use psb_error_mod use psi_alcx_mod implicit none @@ -744,7 +746,8 @@ subroutine psi_calqsrx_up(n,x,idx) ! .. Local Scalars .. complex(psb_spk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=32 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -888,7 +891,7 @@ subroutine psi_calqsrx_up(n,x,idx) end subroutine psi_calqsrx_up subroutine psi_calqsrx_dw(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_calqsrx_dw + use psb_sort_mod, psb_protect_name => psi_calqsrx_dw use psb_error_mod use psi_alcx_mod implicit none @@ -899,7 +902,8 @@ subroutine psi_calqsrx_dw(n,x,idx) ! .. Local Scalars .. complex(psb_spk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=32 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1043,7 +1047,7 @@ subroutine psi_calqsrx_dw(n,x,idx) end subroutine psi_calqsrx_dw subroutine psi_calqsr_up(n,x) - use psb_c_sort_mod, psb_protect_name => psi_calqsr_up + use psb_sort_mod, psb_protect_name => psi_calqsr_up use psb_error_mod use psi_alcx_mod implicit none @@ -1184,7 +1188,7 @@ subroutine psi_calqsr_up(n,x) end subroutine psi_calqsr_up subroutine psi_calqsr_dw(n,x) - use psb_c_sort_mod, psb_protect_name => psi_calqsr_dw + use psb_sort_mod, psb_protect_name => psi_calqsr_dw use psb_error_mod use psi_alcx_mod implicit none @@ -1324,7 +1328,7 @@ subroutine psi_calqsr_dw(n,x) end subroutine psi_calqsr_dw subroutine psi_caqsrx_up(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_caqsrx_up + use psb_sort_mod, psb_protect_name => psi_caqsrx_up use psb_error_mod implicit none @@ -1335,7 +1339,8 @@ subroutine psi_caqsrx_up(n,x,idx) real(psb_spk_) :: piv, xk complex(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=32 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1480,7 +1485,7 @@ subroutine psi_caqsrx_up(n,x,idx) end subroutine psi_caqsrx_up subroutine psi_caqsrx_dw(n,x,idx) - use psb_c_sort_mod, psb_protect_name => psi_caqsrx_dw + use psb_sort_mod, psb_protect_name => psi_caqsrx_dw use psb_error_mod implicit none @@ -1491,7 +1496,8 @@ subroutine psi_caqsrx_dw(n,x,idx) real(psb_spk_) :: piv, xk complex(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=32 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1634,7 +1640,7 @@ subroutine psi_caqsrx_dw(n,x,idx) end subroutine psi_caqsrx_dw subroutine psi_caqsr_up(n,x) - use psb_c_sort_mod, psb_protect_name => psi_caqsr_up + use psb_sort_mod, psb_protect_name => psi_caqsr_up use psb_error_mod implicit none @@ -1644,7 +1650,8 @@ subroutine psi_caqsr_up(n,x) real(psb_spk_) :: piv, xk complex(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=32 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1774,7 +1781,7 @@ subroutine psi_caqsr_up(n,x) end subroutine psi_caqsr_up subroutine psi_caqsr_dw(n,x) - use psb_c_sort_mod, psb_protect_name => psi_caqsr_dw + use psb_sort_mod, psb_protect_name => psi_caqsr_dw use psb_error_mod implicit none @@ -1784,7 +1791,8 @@ subroutine psi_caqsr_dw(n,x) real(psb_spk_) :: piv, xk complex(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=32 integer(psb_ipk_) :: istack(nparms,maxstack) diff --git a/base/serial/sort/psb_d_hsort_impl.f90 b/base/serial/sort/psb_d_hsort_impl.f90 index ce9aa0906..b83e93ccc 100644 --- a/base/serial/sort/psb_d_hsort_impl.f90 +++ b/base/serial/sort/psb_d_hsort_impl.f90 @@ -42,7 +42,7 @@ ! Addison-Wesley ! subroutine psb_dhsort(x,ix,dir,flag) - use psb_d_sort_mod, psb_protect_name => psb_dhsort + use psb_sort_mod, psb_protect_name => psb_dhsort use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -116,13 +116,13 @@ subroutine psb_dhsort(x,ix,dir,flag) do i=1, n key = x(i) index = ix(i) - call psi_d_idx_insert_heap(key,index,l,x,ix,dir_,info) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ' end if end do do i=n, 2, -1 - call psi_d_idx_heap_get_first(key,index,l,x,ix,dir_,info) + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) if (l /= i-1) then write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i end if @@ -133,7 +133,7 @@ subroutine psb_dhsort(x,ix,dir,flag) l = 0 do i=1, n key = x(i) - call psi_d_insert_heap(key,l,x,dir_,info) + call psi_insert_heap(key,l,x,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i end if @@ -185,7 +185,7 @@ end subroutine psb_dhsort ! subroutine psi_d_insert_heap(key,last,heap,dir,info) - use psb_d_sort_mod, psb_protect_name => psi_d_insert_heap + use psb_sort_mod, psb_protect_name => psi_d_insert_heap implicit none ! @@ -291,7 +291,7 @@ end subroutine psi_d_insert_heap subroutine psi_d_heap_get_first(key,last,heap,dir,info) - use psb_d_sort_mod, psb_protect_name => psi_d_heap_get_first + use psb_sort_mod, psb_protect_name => psi_d_heap_get_first implicit none real(psb_dpk_), intent(inout) :: key @@ -415,7 +415,7 @@ end subroutine psi_d_heap_get_first subroutine psi_d_idx_insert_heap(key,index,last,heap,idxs,dir,info) - use psb_d_sort_mod, psb_protect_name => psi_d_idx_insert_heap + use psb_sort_mod, psb_protect_name => psi_d_idx_insert_heap implicit none ! @@ -537,7 +537,7 @@ subroutine psi_d_idx_insert_heap(key,index,last,heap,idxs,dir,info) end subroutine psi_d_idx_insert_heap subroutine psi_d_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - use psb_d_sort_mod, psb_protect_name => psi_d_idx_heap_get_first + use psb_sort_mod, psb_protect_name => psi_d_idx_heap_get_first implicit none real(psb_dpk_), intent(inout) :: heap(:) diff --git a/base/serial/sort/psb_d_isort_impl.f90 b/base/serial/sort/psb_d_isort_impl.f90 index ddf41a381..94e3abd4d 100644 --- a/base/serial/sort/psb_d_isort_impl.f90 +++ b/base/serial/sort/psb_d_isort_impl.f90 @@ -41,14 +41,15 @@ ! Addison-Wesley ! subroutine psb_disort(x,ix,dir,flag) - use psb_d_sort_mod, psb_protect_name => psb_disort + use psb_sort_mod, psb_protect_name => psb_disort use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i + integer(psb_ipk_) :: dir_, flag_, err_act + integer(psb_ipk_) :: n, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -130,7 +131,7 @@ subroutine psb_disort(x,ix,dir,flag) end subroutine psb_disort subroutine psi_disrx_up(n,x,idx) - use psb_d_sort_mod, psb_protect_name => psi_disrx_up + use psb_sort_mod, psb_protect_name => psi_disrx_up use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -158,7 +159,7 @@ subroutine psi_disrx_up(n,x,idx) end subroutine psi_disrx_up subroutine psi_disrx_dw(n,x,idx) - use psb_d_sort_mod, psb_protect_name => psi_disrx_dw + use psb_sort_mod, psb_protect_name => psi_disrx_dw use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -187,7 +188,7 @@ end subroutine psi_disrx_dw subroutine psi_disr_up(n,x) - use psb_d_sort_mod, psb_protect_name => psi_disr_up + use psb_sort_mod, psb_protect_name => psi_disr_up use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -211,7 +212,7 @@ subroutine psi_disr_up(n,x) end subroutine psi_disr_up subroutine psi_disr_dw(n,x) - use psb_d_sort_mod, psb_protect_name => psi_disr_dw + use psb_sort_mod, psb_protect_name => psi_disr_dw use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -235,7 +236,7 @@ subroutine psi_disr_dw(n,x) end subroutine psi_disr_dw subroutine psi_daisrx_up(n,x,idx) - use psb_d_sort_mod, psb_protect_name => psi_daisrx_up + use psb_sort_mod, psb_protect_name => psi_daisrx_up use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -263,7 +264,7 @@ subroutine psi_daisrx_up(n,x,idx) end subroutine psi_daisrx_up subroutine psi_daisrx_dw(n,x,idx) - use psb_d_sort_mod, psb_protect_name => psi_daisrx_dw + use psb_sort_mod, psb_protect_name => psi_daisrx_dw use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -291,7 +292,7 @@ subroutine psi_daisrx_dw(n,x,idx) end subroutine psi_daisrx_dw subroutine psi_daisr_up(n,x) - use psb_d_sort_mod, psb_protect_name => psi_daisr_up + use psb_sort_mod, psb_protect_name => psi_daisr_up use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -315,7 +316,7 @@ subroutine psi_daisr_up(n,x) end subroutine psi_daisr_up subroutine psi_daisr_dw(n,x) - use psb_d_sort_mod, psb_protect_name => psi_daisr_dw + use psb_sort_mod, psb_protect_name => psi_daisr_dw use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) diff --git a/base/serial/sort/psb_d_msort_impl.f90 b/base/serial/sort/psb_d_msort_impl.f90 index b0d7f8b54..01491b0b0 100644 --- a/base/serial/sort/psb_d_msort_impl.f90 +++ b/base/serial/sort/psb_d_msort_impl.f90 @@ -42,7 +42,7 @@ ! subroutine psb_dmsort_u(x,nout,dir) - use psb_d_sort_mod, psb_protect_name => psb_dmsort_u + use psb_sort_mod, psb_protect_name => psb_dmsort_u use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) @@ -78,7 +78,7 @@ function psb_dbsrch(key,n,v) result(ipos) - use psb_d_sort_mod, psb_protect_name => psb_dbsrch + use psb_sort_mod, psb_protect_name => psb_dbsrch implicit none integer(psb_ipk_) :: ipos, n real(psb_dpk_) :: key @@ -115,7 +115,7 @@ end function psb_dbsrch function psb_dssrch(key,n,v) result(ipos) - use psb_d_sort_mod, psb_protect_name => psb_dssrch + use psb_sort_mod, psb_protect_name => psb_dssrch implicit none integer(psb_ipk_) :: ipos, n real(psb_dpk_) :: key @@ -135,7 +135,7 @@ end function psb_dssrch subroutine psb_dmsort(x,ix,dir,flag) - use psb_d_sort_mod, psb_protect_name => psb_dmsort + use psb_sort_mod, psb_protect_name => psb_dmsort use psb_error_mod use psb_ip_reord_mod implicit none diff --git a/base/serial/sort/psb_d_qsort_impl.f90 b/base/serial/sort/psb_d_qsort_impl.f90 index 105e94d00..13328188f 100644 --- a/base/serial/sort/psb_d_qsort_impl.f90 +++ b/base/serial/sort/psb_d_qsort_impl.f90 @@ -41,15 +41,15 @@ ! Addison-Wesley ! subroutine psb_dqsort(x,ix,dir,flag) - use psb_d_sort_mod, psb_protect_name => psb_dqsort + use psb_sort_mod, psb_protect_name => psb_dqsort use psb_error_mod implicit none real(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i - + integer(psb_ipk_) :: dir_, flag_, err_act, i + integer(psb_ipk_) :: n integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -130,7 +130,7 @@ subroutine psb_dqsort(x,ix,dir,flag) end subroutine psb_dqsort subroutine psi_dqsrx_up(n,x,idx) - use psb_d_sort_mod, psb_protect_name => psi_dqsrx_up + use psb_sort_mod, psb_protect_name => psi_dqsrx_up use psb_error_mod implicit none @@ -140,7 +140,8 @@ subroutine psi_dqsrx_up(n,x,idx) ! .. Local Scalars .. real(psb_dpk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=60 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -283,7 +284,7 @@ subroutine psi_dqsrx_up(n,x,idx) end subroutine psi_dqsrx_up subroutine psi_dqsrx_dw(n,x,idx) - use psb_d_sort_mod, psb_protect_name => psi_dqsrx_dw + use psb_sort_mod, psb_protect_name => psi_dqsrx_dw use psb_error_mod implicit none @@ -293,7 +294,8 @@ subroutine psi_dqsrx_dw(n,x,idx) ! .. Local Scalars .. real(psb_dpk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=60 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -438,7 +440,7 @@ subroutine psi_dqsrx_dw(n,x,idx) end subroutine psi_dqsrx_dw subroutine psi_dqsr_up(n,x) - use psb_d_sort_mod, psb_protect_name => psi_dqsr_up + use psb_sort_mod, psb_protect_name => psi_dqsr_up use psb_error_mod implicit none @@ -579,7 +581,7 @@ subroutine psi_dqsr_up(n,x) end subroutine psi_dqsr_up subroutine psi_dqsr_dw(n,x) - use psb_d_sort_mod, psb_protect_name => psi_dqsr_dw + use psb_sort_mod, psb_protect_name => psi_dqsr_dw use psb_error_mod implicit none @@ -720,7 +722,7 @@ subroutine psi_dqsr_dw(n,x) end subroutine psi_dqsr_dw subroutine psi_daqsrx_up(n,x,idx) - use psb_d_sort_mod, psb_protect_name => psi_daqsrx_up + use psb_sort_mod, psb_protect_name => psi_daqsrx_up use psb_error_mod implicit none @@ -731,7 +733,8 @@ subroutine psi_daqsrx_up(n,x,idx) real(psb_dpk_) :: piv, xk real(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=60 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -876,7 +879,7 @@ subroutine psi_daqsrx_up(n,x,idx) end subroutine psi_daqsrx_up subroutine psi_daqsrx_dw(n,x,idx) - use psb_d_sort_mod, psb_protect_name => psi_daqsrx_dw + use psb_sort_mod, psb_protect_name => psi_daqsrx_dw use psb_error_mod implicit none @@ -887,7 +890,8 @@ subroutine psi_daqsrx_dw(n,x,idx) real(psb_dpk_) :: piv, xk real(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=60 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1030,7 +1034,7 @@ subroutine psi_daqsrx_dw(n,x,idx) end subroutine psi_daqsrx_dw subroutine psi_daqsr_up(n,x) - use psb_d_sort_mod, psb_protect_name => psi_daqsr_up + use psb_sort_mod, psb_protect_name => psi_daqsr_up use psb_error_mod implicit none @@ -1040,7 +1044,8 @@ subroutine psi_daqsr_up(n,x) real(psb_dpk_) :: piv, xk real(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=60 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1170,7 +1175,7 @@ subroutine psi_daqsr_up(n,x) end subroutine psi_daqsr_up subroutine psi_daqsr_dw(n,x) - use psb_d_sort_mod, psb_protect_name => psi_daqsr_dw + use psb_sort_mod, psb_protect_name => psi_daqsr_dw use psb_error_mod implicit none @@ -1180,7 +1185,8 @@ subroutine psi_daqsr_dw(n,x) real(psb_dpk_) :: piv, xk real(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=60 integer(psb_ipk_) :: istack(nparms,maxstack) diff --git a/base/serial/sort/psb_e_hsort_impl.f90 b/base/serial/sort/psb_e_hsort_impl.f90 new file mode 100644 index 000000000..d6990f36f --- /dev/null +++ b/base/serial/sort/psb_e_hsort_impl.f90 @@ -0,0 +1,678 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The merge-sort and quicksort routines are implemented in the +! serial/aux directory +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_ehsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_ehsort + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_epk_) :: key + integer(psb_epk_) :: index + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + select case(dir_) + case(psb_sort_up_,psb_sort_down_) + ! OK + case (psb_asort_up_,psb_asort_down_) + ! OK + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_ + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_ == psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_heap(key,l,x,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_e_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_ehsort + + + +! +! These are packaged so that they can be used to implement +! a heapsort, should the need arise +! +! +! Programming note: +! In the implementation of the heap_get_first function +! we have code like this +! +! if ( ( heap(2*i) < heap(2*i+1) ) .or.& +! & (2*i == last)) then +! j = 2*i +! else +! j = 2*i + 1 +! end if +! +! It looks like the 2*i+1 could overflow the array, but this +! is not true because there is a guard statement +! if (i>last/2) exit +! and because last has just been reduced by 1 when defining the return value, +! therefore 2*i+1 may be greater than the current value of last, +! but cannot be greater than the value of last when the routine was entered +! hence it is safe. +! +! +! + +subroutine psi_e_insert_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_e_insert_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_epk_), intent(in) :: key + integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(inout) :: heap(:) + integer(psb_epk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2 + integer(psb_epk_) :: temp + + info = psb_success_ + if (last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(psb_err_unit,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_e_insert_heap + + +subroutine psi_e_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_e_heap_get_first + implicit none + + integer(psb_epk_), intent(inout) :: key + integer(psb_epk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, j + integer(psb_epk_) :: temp + + + info = psb_success_ + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_e_heap_get_first + + +subroutine psi_e_idx_insert_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_e_idx_insert_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + integer(psb_epk_), intent(in) :: key + integer(psb_ipk_), intent(in) :: index,dir + integer(psb_epk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:),last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2, itemp + integer(psb_epk_) :: temp + + info = psb_success_ + if (last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(psb_err_unit,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_e_idx_insert_heap + +subroutine psi_e_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_e_idx_heap_get_first + implicit none + + integer(psb_epk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(inout) :: last,idxs(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_epk_), intent(out) :: key + + integer(psb_ipk_) :: i, j,itemp + integer(psb_epk_) :: temp + + info = psb_success_ + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_e_idx_heap_get_first + + + + diff --git a/base/serial/sort/psb_e_isort_impl.f90 b/base/serial/sort/psb_e_isort_impl.f90 new file mode 100644 index 000000000..0fe323185 --- /dev/null +++ b/base/serial/sort/psb_e_isort_impl.f90 @@ -0,0 +1,341 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The insertion sort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_eisort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_eisort + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, err_act + integer(psb_epk_) :: n, i + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_eisort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1,n + ix(i) = i + end do + end if + + select case(dir_) + case (psb_sort_up_) + call psi_eisrx_up(n,x,ix) + case (psb_sort_down_) + call psi_eisrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_eaisrx_up(n,x,ix) + case (psb_asort_down_) + call psi_eaisrx_dw(n,x,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + else + select case(dir_) + case (psb_sort_up_) + call psi_eisr_up(n,x) + case (psb_sort_down_) + call psi_eisr_dw(n,x) + case (psb_asort_up_) + call psi_eaisr_up(n,x) + case (psb_asort_down_) + call psi_eaisr_dw(n,x) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_eisort + +subroutine psi_eisrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_eisrx_up + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: idx(:) + integer(psb_epk_), intent(in) :: n + integer(psb_epk_) :: i,j,ix + integer(psb_epk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_eisrx_up + +subroutine psi_eisrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_eisrx_dw + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: idx(:) + integer(psb_epk_), intent(in) :: n + integer(psb_epk_) :: i,j,ix + integer(psb_epk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_eisrx_dw + + +subroutine psi_eisr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_eisr_up + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + integer(psb_epk_) :: i,j + integer(psb_epk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_eisr_up + +subroutine psi_eisr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_eisr_dw + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + integer(psb_epk_) :: i,j + integer(psb_epk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_eisr_dw + +subroutine psi_eaisrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_eaisrx_up + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: idx(:) + integer(psb_epk_), intent(in) :: n + integer(psb_epk_) :: i,j,ix + integer(psb_epk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= abs(xx)) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_eaisrx_up + +subroutine psi_eaisrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_eaisrx_dw + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: idx(:) + integer(psb_epk_), intent(in) :: n + integer(psb_epk_) :: i,j,ix + integer(psb_epk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= abs(xx)) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_eaisrx_dw + +subroutine psi_eaisr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_eaisr_up + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + integer(psb_epk_) :: i,j + integer(psb_epk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= abs(xx)) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_eaisr_up + +subroutine psi_eaisr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_eaisr_dw + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + integer(psb_epk_) :: i,j + integer(psb_epk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= abs(xx)) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_eaisr_dw + diff --git a/base/serial/sort/psb_e_msort_impl.f90 b/base/serial/sort/psb_e_msort_impl.f90 new file mode 100644 index 000000000..2950d7bd0 --- /dev/null +++ b/base/serial/sort/psb_e_msort_impl.f90 @@ -0,0 +1,713 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + ! + ! The merge-sort routines + ! References: + ! D. Knuth + ! The Art of Computer Programming, vol. 3 + ! Addison-Wesley + ! + ! Aho, Hopcroft, Ullman + ! Data Structures and Algorithms + ! Addison-Wesley + ! + logical function psb_eisaperm(n,eip) + use psb_sort_mod, psb_protect_name => psb_eisaperm + implicit none + + integer(psb_epk_), intent(in) :: n + integer(psb_epk_), intent(in) :: eip(n) + integer(psb_epk_), allocatable :: ip(:) + integer(psb_epk_) :: i,j,m, info + + + psb_eisaperm = .true. + if (n <= 0) return + allocate(ip(n), stat=info) + if (info /= psb_success_) return + ! + ! sanity check first + ! + do i=1, n + ip(i) = eip(i) + if ((ip(i) < 1).or.(ip(i) > n)) then + write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n + psb_eisaperm = .false. + return + endif + enddo + + ! + ! now work through the cycles, by marking each successive item as negative. + ! no cycle should intersect with any other, hence the >= 1 check. + ! + do m = 1, n + i = ip(m) + if (i < 0) then + ip(m) = -i + else if (i /= m) then + j = ip(i) + ip(i) = -j + i = j + do while ((j >= 1).and.(j /= m)) + j = ip(i) + ip(i) = -j + i = j + enddo + ip(m) = abs(ip(m)) + if (j /= m) then + psb_eisaperm = .false. + goto 9999 + endif + end if + enddo +9999 continue + + return + end function psb_eisaperm + + + subroutine psb_emsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_emsort_u + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + + integer(psb_epk_) :: n, k + integer(psb_ipk_) :: err_act + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_msort_u' + call psb_erractionsave(err_act) + + n = size(x) + + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo + + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_emsort_u + + + function psb_ebsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_ebsrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_epk_) :: key + integer(psb_epk_) :: v(:) + + integer(psb_ipk_) :: lb, ub, m, i + + ipos = -1 + if (n<5) then + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + return + end if + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + lb = ub + 1 + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + return + end function psb_ebsrch + + function psb_essrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_essrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_epk_) :: key + integer(psb_epk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return + end function psb_essrch + + subroutine psb_emsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_emsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_epk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_emsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_e_msort') + goto 9999 + endif + + select case(dir_) + case (psb_sort_up_) + call psi_e_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_e_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_e_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_e_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if + end if + + + return + +9999 call psb_error_handler(err_act) + + return + + + end subroutine psb_emsort + + subroutine psi_e_msort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + ! + integer(psb_epk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) > k(q)) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_e_msort_up + + subroutine psi_e_msort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + ! + integer(psb_epk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) < k(q)) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_e_msort_dw + + subroutine psi_e_amsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + ! + integer(psb_epk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) <= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (abs(k(p)) > abs(k(q))) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (abs(k(p)) <= abs(k(q))) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) > abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_e_amsort_up + + subroutine psi_e_amsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_epk_) :: k(n) + integer(psb_epk_) :: l(0:n+1) + ! + integer(psb_epk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) >= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (abs(k(p)) < abs(k(q))) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (abs(k(p)) >= abs(k(q))) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) < abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_e_amsort_dw + + + + + + + + diff --git a/base/serial/sort/psb_e_qsort_impl.f90 b/base/serial/sort/psb_e_qsort_impl.f90 new file mode 100644 index 000000000..9b95c78ee --- /dev/null +++ b/base/serial/sort/psb_e_qsort_impl.f90 @@ -0,0 +1,1318 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_eqsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_eqsort + use psb_error_mod + implicit none + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_epk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, err_act, i + integer(psb_epk_) :: n + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_eqsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1,n + ix(i) = i + end do + end if + + select case(dir_) + case (psb_sort_up_) + call psi_eqsrx_up(n,x,ix) + case (psb_sort_down_) + call psi_eqsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_eaqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_eaqsrx_dw(n,x,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + else + select case(dir_) + case (psb_sort_up_) + call psi_eqsr_up(n,x) + case (psb_sort_down_) + call psi_eqsr_dw(n,x) + case (psb_asort_up_) + call psi_eaqsr_up(n,x) + case (psb_asort_down_) + call psi_eaqsr_dw(n,x) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_eqsort + +subroutine psi_eqsrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_eqsrx_up + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: idx(:) + integer(psb_epk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_epk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_epk_) :: n1, n2 + integer(psb_epk_) :: ixt + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_eqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eisrx_up(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eisrx_up(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_eisrx_up(n,x,idx) + endif +end subroutine psi_eqsrx_up + +subroutine psi_eqsrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_eqsrx_dw + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: idx(:) + integer(psb_epk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_epk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_epk_) :: n1, n2 + integer(psb_epk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_eqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_eisrx_dw(n,x,idx) + endif + +end subroutine psi_eqsrx_dw + +subroutine psi_eqsr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_eqsr_up + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_epk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_epk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_eqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_eisr_up(n,x) + endif + +end subroutine psi_eqsr_up + +subroutine psi_eqsr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_eqsr_dw + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_epk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_epk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_eqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_eisr_dw(n,x) + endif + +end subroutine psi_eqsr_dw + +subroutine psi_eaqsrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_eaqsrx_up + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: idx(:) + integer(psb_epk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_epk_) :: piv, xk + integer(psb_epk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_epk_) :: n1, n2 + integer(psb_epk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_eaqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eaisrx_up(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eaisrx_up(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_eaisrx_up(n,x,idx) + endif + + +end subroutine psi_eaqsrx_up + +subroutine psi_eaqsrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_eaqsrx_dw + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(inout) :: idx(:) + integer(psb_epk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_epk_) :: piv, xk + integer(psb_epk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_epk_) :: n1, n2 + integer(psb_epk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_eaqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eaisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eaisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_eaisrx_dw(n,x,idx) + endif + +end subroutine psi_eaqsrx_dw + +subroutine psi_eaqsr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_eaqsr_up + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_epk_) :: piv, xk + integer(psb_epk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_epk_) :: n1, n2 + integer(psb_epk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_eqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eaisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eaisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eaisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eaisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_eaisr_up(n,x) + endif + +end subroutine psi_eaqsr_up + +subroutine psi_eaqsr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_eaqsr_dw + use psb_error_mod + implicit none + + integer(psb_epk_), intent(inout) :: x(:) + integer(psb_epk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_epk_) :: piv, xk + integer(psb_epk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_epk_) :: n1, n2 + integer(psb_epk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_eqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eaisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eaisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_eaisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_eaisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_eaisr_dw(n,x) + endif + +end subroutine psi_eaqsr_dw + + diff --git a/base/serial/sort/psb_i_hsort_impl.f90 b/base/serial/sort/psb_i_hsort_impl.f90 index 17c48f626..1c53650ad 100644 --- a/base/serial/sort/psb_i_hsort_impl.f90 +++ b/base/serial/sort/psb_i_hsort_impl.f90 @@ -42,7 +42,7 @@ ! Addison-Wesley ! subroutine psb_ihsort(x,ix,dir,flag) - use psb_i_sort_mod, psb_protect_name => psb_ihsort + use psb_sort_mod, psb_protect_name => psb_ihsort use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -116,13 +116,13 @@ subroutine psb_ihsort(x,ix,dir,flag) do i=1, n key = x(i) index = ix(i) - call psi_i_idx_insert_heap(key,index,l,x,ix,dir_,info) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ' end if end do do i=n, 2, -1 - call psi_i_idx_heap_get_first(key,index,l,x,ix,dir_,info) + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) if (l /= i-1) then write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i end if @@ -133,7 +133,7 @@ subroutine psb_ihsort(x,ix,dir,flag) l = 0 do i=1, n key = x(i) - call psi_i_insert_heap(key,l,x,dir_,info) + call psi_insert_heap(key,l,x,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i end if @@ -185,7 +185,7 @@ end subroutine psb_ihsort ! subroutine psi_i_insert_heap(key,last,heap,dir,info) - use psb_i_sort_mod, psb_protect_name => psi_i_insert_heap + use psb_sort_mod, psb_protect_name => psi_i_insert_heap implicit none ! @@ -291,7 +291,7 @@ end subroutine psi_i_insert_heap subroutine psi_i_heap_get_first(key,last,heap,dir,info) - use psb_i_sort_mod, psb_protect_name => psi_i_heap_get_first + use psb_sort_mod, psb_protect_name => psi_i_heap_get_first implicit none integer(psb_ipk_), intent(inout) :: key @@ -415,7 +415,7 @@ end subroutine psi_i_heap_get_first subroutine psi_i_idx_insert_heap(key,index,last,heap,idxs,dir,info) - use psb_i_sort_mod, psb_protect_name => psi_i_idx_insert_heap + use psb_sort_mod, psb_protect_name => psi_i_idx_insert_heap implicit none ! @@ -537,7 +537,7 @@ subroutine psi_i_idx_insert_heap(key,index,last,heap,idxs,dir,info) end subroutine psi_i_idx_insert_heap subroutine psi_i_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - use psb_i_sort_mod, psb_protect_name => psi_i_idx_heap_get_first + use psb_sort_mod, psb_protect_name => psi_i_idx_heap_get_first implicit none integer(psb_ipk_), intent(inout) :: heap(:) diff --git a/base/serial/sort/psb_i_isort_impl.f90 b/base/serial/sort/psb_i_isort_impl.f90 index ccaec9b7c..41c1381f7 100644 --- a/base/serial/sort/psb_i_isort_impl.f90 +++ b/base/serial/sort/psb_i_isort_impl.f90 @@ -41,14 +41,15 @@ ! Addison-Wesley ! subroutine psb_iisort(x,ix,dir,flag) - use psb_i_sort_mod, psb_protect_name => psb_iisort + use psb_sort_mod, psb_protect_name => psb_iisort use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i + integer(psb_ipk_) :: dir_, flag_, err_act + integer(psb_ipk_) :: n, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -130,7 +131,7 @@ subroutine psb_iisort(x,ix,dir,flag) end subroutine psb_iisort subroutine psi_iisrx_up(n,x,idx) - use psb_i_sort_mod, psb_protect_name => psi_iisrx_up + use psb_sort_mod, psb_protect_name => psi_iisrx_up use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -158,7 +159,7 @@ subroutine psi_iisrx_up(n,x,idx) end subroutine psi_iisrx_up subroutine psi_iisrx_dw(n,x,idx) - use psb_i_sort_mod, psb_protect_name => psi_iisrx_dw + use psb_sort_mod, psb_protect_name => psi_iisrx_dw use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -187,7 +188,7 @@ end subroutine psi_iisrx_dw subroutine psi_iisr_up(n,x) - use psb_i_sort_mod, psb_protect_name => psi_iisr_up + use psb_sort_mod, psb_protect_name => psi_iisr_up use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -211,7 +212,7 @@ subroutine psi_iisr_up(n,x) end subroutine psi_iisr_up subroutine psi_iisr_dw(n,x) - use psb_i_sort_mod, psb_protect_name => psi_iisr_dw + use psb_sort_mod, psb_protect_name => psi_iisr_dw use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -235,7 +236,7 @@ subroutine psi_iisr_dw(n,x) end subroutine psi_iisr_dw subroutine psi_iaisrx_up(n,x,idx) - use psb_i_sort_mod, psb_protect_name => psi_iaisrx_up + use psb_sort_mod, psb_protect_name => psi_iaisrx_up use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -263,7 +264,7 @@ subroutine psi_iaisrx_up(n,x,idx) end subroutine psi_iaisrx_up subroutine psi_iaisrx_dw(n,x,idx) - use psb_i_sort_mod, psb_protect_name => psi_iaisrx_dw + use psb_sort_mod, psb_protect_name => psi_iaisrx_dw use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -291,7 +292,7 @@ subroutine psi_iaisrx_dw(n,x,idx) end subroutine psi_iaisrx_dw subroutine psi_iaisr_up(n,x) - use psb_i_sort_mod, psb_protect_name => psi_iaisr_up + use psb_sort_mod, psb_protect_name => psi_iaisr_up use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -315,7 +316,7 @@ subroutine psi_iaisr_up(n,x) end subroutine psi_iaisr_up subroutine psi_iaisr_dw(n,x) - use psb_i_sort_mod, psb_protect_name => psi_iaisr_dw + use psb_sort_mod, psb_protect_name => psi_iaisr_dw use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) diff --git a/base/serial/sort/psb_i_msort_impl.f90 b/base/serial/sort/psb_i_msort_impl.f90 index 2e8557189..1e9ad9ecb 100644 --- a/base/serial/sort/psb_i_msort_impl.f90 +++ b/base/serial/sort/psb_i_msort_impl.f90 @@ -40,8 +40,8 @@ ! Data Structures and Algorithms ! Addison-Wesley ! - logical function psb_isaperm(n,eip) - use psb_i_sort_mod, psb_protect_name => psb_isaperm + logical function psb_iisaperm(n,eip) + use psb_sort_mod, psb_protect_name => psb_iisaperm implicit none integer(psb_ipk_), intent(in) :: n @@ -50,7 +50,7 @@ integer(psb_ipk_) :: i,j,m, info - psb_isaperm = .true. + psb_iisaperm = .true. if (n <= 0) return allocate(ip(n), stat=info) if (info /= psb_success_) return @@ -61,7 +61,7 @@ ip(i) = eip(i) if ((ip(i) < 1).or.(ip(i) > n)) then write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n - psb_isaperm = .false. + psb_iisaperm = .false. return endif enddo @@ -85,7 +85,7 @@ enddo ip(m) = abs(ip(m)) if (j /= m) then - psb_isaperm = .false. + psb_iisaperm = .false. goto 9999 endif end if @@ -93,11 +93,11 @@ 9999 continue return - end function psb_isaperm + end function psb_iisaperm subroutine psb_imsort_u(x,nout,dir) - use psb_i_sort_mod, psb_protect_name => psb_imsort_u + use psb_sort_mod, psb_protect_name => psb_imsort_u use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) @@ -133,7 +133,7 @@ function psb_ibsrch(key,n,v) result(ipos) - use psb_i_sort_mod, psb_protect_name => psb_ibsrch + use psb_sort_mod, psb_protect_name => psb_ibsrch implicit none integer(psb_ipk_) :: ipos, n integer(psb_ipk_) :: key @@ -170,7 +170,7 @@ end function psb_ibsrch function psb_issrch(key,n,v) result(ipos) - use psb_i_sort_mod, psb_protect_name => psb_issrch + use psb_sort_mod, psb_protect_name => psb_issrch implicit none integer(psb_ipk_) :: ipos, n integer(psb_ipk_) :: key @@ -190,7 +190,7 @@ end function psb_issrch subroutine psb_imsort(x,ix,dir,flag) - use psb_i_sort_mod, psb_protect_name => psb_imsort + use psb_sort_mod, psb_protect_name => psb_imsort use psb_error_mod use psb_ip_reord_mod implicit none diff --git a/base/serial/sort/psb_i_qsort_impl.f90 b/base/serial/sort/psb_i_qsort_impl.f90 index a16ef9108..e5f0ac927 100644 --- a/base/serial/sort/psb_i_qsort_impl.f90 +++ b/base/serial/sort/psb_i_qsort_impl.f90 @@ -41,15 +41,15 @@ ! Addison-Wesley ! subroutine psb_iqsort(x,ix,dir,flag) - use psb_i_sort_mod, psb_protect_name => psb_iqsort + use psb_sort_mod, psb_protect_name => psb_iqsort use psb_error_mod implicit none integer(psb_ipk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i - + integer(psb_ipk_) :: dir_, flag_, err_act, i + integer(psb_ipk_) :: n integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -130,7 +130,7 @@ subroutine psb_iqsort(x,ix,dir,flag) end subroutine psb_iqsort subroutine psi_iqsrx_up(n,x,idx) - use psb_i_sort_mod, psb_protect_name => psi_iqsrx_up + use psb_sort_mod, psb_protect_name => psi_iqsrx_up use psb_error_mod implicit none @@ -140,7 +140,8 @@ subroutine psi_iqsrx_up(n,x,idx) ! .. Local Scalars .. integer(psb_ipk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -283,7 +284,7 @@ subroutine psi_iqsrx_up(n,x,idx) end subroutine psi_iqsrx_up subroutine psi_iqsrx_dw(n,x,idx) - use psb_i_sort_mod, psb_protect_name => psi_iqsrx_dw + use psb_sort_mod, psb_protect_name => psi_iqsrx_dw use psb_error_mod implicit none @@ -293,7 +294,8 @@ subroutine psi_iqsrx_dw(n,x,idx) ! .. Local Scalars .. integer(psb_ipk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -438,7 +440,7 @@ subroutine psi_iqsrx_dw(n,x,idx) end subroutine psi_iqsrx_dw subroutine psi_iqsr_up(n,x) - use psb_i_sort_mod, psb_protect_name => psi_iqsr_up + use psb_sort_mod, psb_protect_name => psi_iqsr_up use psb_error_mod implicit none @@ -579,7 +581,7 @@ subroutine psi_iqsr_up(n,x) end subroutine psi_iqsr_up subroutine psi_iqsr_dw(n,x) - use psb_i_sort_mod, psb_protect_name => psi_iqsr_dw + use psb_sort_mod, psb_protect_name => psi_iqsr_dw use psb_error_mod implicit none @@ -720,7 +722,7 @@ subroutine psi_iqsr_dw(n,x) end subroutine psi_iqsr_dw subroutine psi_iaqsrx_up(n,x,idx) - use psb_i_sort_mod, psb_protect_name => psi_iaqsrx_up + use psb_sort_mod, psb_protect_name => psi_iaqsrx_up use psb_error_mod implicit none @@ -731,7 +733,8 @@ subroutine psi_iaqsrx_up(n,x,idx) integer(psb_ipk_) :: piv, xk integer(psb_ipk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -876,7 +879,7 @@ subroutine psi_iaqsrx_up(n,x,idx) end subroutine psi_iaqsrx_up subroutine psi_iaqsrx_dw(n,x,idx) - use psb_i_sort_mod, psb_protect_name => psi_iaqsrx_dw + use psb_sort_mod, psb_protect_name => psi_iaqsrx_dw use psb_error_mod implicit none @@ -887,7 +890,8 @@ subroutine psi_iaqsrx_dw(n,x,idx) integer(psb_ipk_) :: piv, xk integer(psb_ipk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1030,7 +1034,7 @@ subroutine psi_iaqsrx_dw(n,x,idx) end subroutine psi_iaqsrx_dw subroutine psi_iaqsr_up(n,x) - use psb_i_sort_mod, psb_protect_name => psi_iaqsr_up + use psb_sort_mod, psb_protect_name => psi_iaqsr_up use psb_error_mod implicit none @@ -1040,7 +1044,8 @@ subroutine psi_iaqsr_up(n,x) integer(psb_ipk_) :: piv, xk integer(psb_ipk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1170,7 +1175,7 @@ subroutine psi_iaqsr_up(n,x) end subroutine psi_iaqsr_up subroutine psi_iaqsr_dw(n,x) - use psb_i_sort_mod, psb_protect_name => psi_iaqsr_dw + use psb_sort_mod, psb_protect_name => psi_iaqsr_dw use psb_error_mod implicit none @@ -1180,7 +1185,8 @@ subroutine psi_iaqsr_dw(n,x) integer(psb_ipk_) :: piv, xk integer(psb_ipk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) diff --git a/base/serial/sort/psb_l_hsort_impl.f90 b/base/serial/sort/psb_l_hsort_impl.f90 new file mode 100644 index 000000000..f8337eb47 --- /dev/null +++ b/base/serial/sort/psb_l_hsort_impl.f90 @@ -0,0 +1,678 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The merge-sort and quicksort routines are implemented in the +! serial/aux directory +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_lhsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_lhsort + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_lpk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_lpk_) :: key + integer(psb_lpk_) :: index + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + select case(dir_) + case(psb_sort_up_,psb_sort_down_) + ! OK + case (psb_asort_up_,psb_asort_down_) + ! OK + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_ + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_ == psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_heap(key,l,x,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_l_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lhsort + + + +! +! These are packaged so that they can be used to implement +! a heapsort, should the need arise +! +! +! Programming note: +! In the implementation of the heap_get_first function +! we have code like this +! +! if ( ( heap(2*i) < heap(2*i+1) ) .or.& +! & (2*i == last)) then +! j = 2*i +! else +! j = 2*i + 1 +! end if +! +! It looks like the 2*i+1 could overflow the array, but this +! is not true because there is a guard statement +! if (i>last/2) exit +! and because last has just been reduced by 1 when defining the return value, +! therefore 2*i+1 may be greater than the current value of last, +! but cannot be greater than the value of last when the routine was entered +! hence it is safe. +! +! +! + +subroutine psi_l_insert_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_l_insert_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_lpk_), intent(in) :: key + integer(psb_ipk_), intent(in) :: dir + integer(psb_lpk_), intent(inout) :: heap(:) + integer(psb_lpk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2 + integer(psb_lpk_) :: temp + + info = psb_success_ + if (last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(psb_err_unit,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_l_insert_heap + + +subroutine psi_l_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_l_heap_get_first + implicit none + + integer(psb_lpk_), intent(inout) :: key + integer(psb_lpk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + integer(psb_lpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, j + integer(psb_lpk_) :: temp + + + info = psb_success_ + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_l_heap_get_first + + +subroutine psi_l_idx_insert_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_l_idx_insert_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + integer(psb_lpk_), intent(in) :: key + integer(psb_ipk_), intent(in) :: index,dir + integer(psb_lpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:),last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2, itemp + integer(psb_lpk_) :: temp + + info = psb_success_ + if (last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(psb_err_unit,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_l_idx_insert_heap + +subroutine psi_l_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_l_idx_heap_get_first + implicit none + + integer(psb_lpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(inout) :: last,idxs(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_lpk_), intent(out) :: key + + integer(psb_ipk_) :: i, j,itemp + integer(psb_lpk_) :: temp + + info = psb_success_ + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_l_idx_heap_get_first + + + + diff --git a/base/serial/sort/psb_l_isort_impl.f90 b/base/serial/sort/psb_l_isort_impl.f90 new file mode 100644 index 000000000..8d101759f --- /dev/null +++ b/base/serial/sort/psb_l_isort_impl.f90 @@ -0,0 +1,341 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The insertion sort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_lisort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_lisort + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_lpk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, err_act + integer(psb_lpk_) :: n, i + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_lisort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1,n + ix(i) = i + end do + end if + + select case(dir_) + case (psb_sort_up_) + call psi_lisrx_up(n,x,ix) + case (psb_sort_down_) + call psi_lisrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_laisrx_up(n,x,ix) + case (psb_asort_down_) + call psi_laisrx_dw(n,x,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + else + select case(dir_) + case (psb_sort_up_) + call psi_lisr_up(n,x) + case (psb_sort_down_) + call psi_lisr_dw(n,x) + case (psb_asort_up_) + call psi_laisr_up(n,x) + case (psb_asort_down_) + call psi_laisr_dw(n,x) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lisort + +subroutine psi_lisrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_lisrx_up + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_) :: i,j,ix + integer(psb_lpk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_lisrx_up + +subroutine psi_lisrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_lisrx_dw + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_) :: i,j,ix + integer(psb_lpk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_lisrx_dw + + +subroutine psi_lisr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_lisr_up + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_) :: i,j + integer(psb_lpk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_lisr_up + +subroutine psi_lisr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_lisr_dw + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_) :: i,j + integer(psb_lpk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_lisr_dw + +subroutine psi_laisrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_laisrx_up + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_) :: i,j,ix + integer(psb_lpk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= abs(xx)) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_laisrx_up + +subroutine psi_laisrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_laisrx_dw + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_) :: i,j,ix + integer(psb_lpk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= abs(xx)) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_laisrx_dw + +subroutine psi_laisr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_laisr_up + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_) :: i,j + integer(psb_lpk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= abs(xx)) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_laisr_up + +subroutine psi_laisr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_laisr_dw + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_) :: i,j + integer(psb_lpk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= abs(xx)) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_laisr_dw + diff --git a/base/serial/sort/psb_l_msort_impl.f90 b/base/serial/sort/psb_l_msort_impl.f90 new file mode 100644 index 000000000..2508b332e --- /dev/null +++ b/base/serial/sort/psb_l_msort_impl.f90 @@ -0,0 +1,713 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + ! + ! The merge-sort routines + ! References: + ! D. Knuth + ! The Art of Computer Programming, vol. 3 + ! Addison-Wesley + ! + ! Aho, Hopcroft, Ullman + ! Data Structures and Algorithms + ! Addison-Wesley + ! + logical function psb_lisaperm(n,eip) + use psb_sort_mod, psb_protect_name => psb_lisaperm + implicit none + + integer(psb_lpk_), intent(in) :: n + integer(psb_lpk_), intent(in) :: eip(n) + integer(psb_lpk_), allocatable :: ip(:) + integer(psb_lpk_) :: i,j,m, info + + + psb_lisaperm = .true. + if (n <= 0) return + allocate(ip(n), stat=info) + if (info /= psb_success_) return + ! + ! sanity check first + ! + do i=1, n + ip(i) = eip(i) + if ((ip(i) < 1).or.(ip(i) > n)) then + write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n + psb_lisaperm = .false. + return + endif + enddo + + ! + ! now work through the cycles, by marking each successive item as negative. + ! no cycle should intersect with any other, hence the >= 1 check. + ! + do m = 1, n + i = ip(m) + if (i < 0) then + ip(m) = -i + else if (i /= m) then + j = ip(i) + ip(i) = -j + i = j + do while ((j >= 1).and.(j /= m)) + j = ip(i) + ip(i) = -j + i = j + enddo + ip(m) = abs(ip(m)) + if (j /= m) then + psb_lisaperm = .false. + goto 9999 + endif + end if + enddo +9999 continue + + return + end function psb_lisaperm + + + subroutine psb_lmsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_lmsort_u + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + + integer(psb_lpk_) :: n, k + integer(psb_ipk_) :: err_act + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_msort_u' + call psb_erractionsave(err_act) + + n = size(x) + + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo + + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_lmsort_u + + + function psb_lbsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_lbsrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_lpk_) :: key + integer(psb_lpk_) :: v(:) + + integer(psb_ipk_) :: lb, ub, m, i + + ipos = -1 + if (n<5) then + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + return + end if + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + lb = ub + 1 + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + return + end function psb_lbsrch + + function psb_lssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_lssrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_lpk_) :: key + integer(psb_lpk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return + end function psb_lssrch + + subroutine psb_lmsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_lmsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_lpk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_lpk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_lmsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_l_msort') + goto 9999 + endif + + select case(dir_) + case (psb_sort_up_) + call psi_l_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_l_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_l_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_l_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if + end if + + + return + +9999 call psb_error_handler(err_act) + + return + + + end subroutine psb_lmsort + + subroutine psi_l_msort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_lpk_) :: k(n) + integer(psb_lpk_) :: l(0:n+1) + ! + integer(psb_lpk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) > k(q)) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_l_msort_up + + subroutine psi_l_msort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_lpk_) :: k(n) + integer(psb_lpk_) :: l(0:n+1) + ! + integer(psb_lpk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) < k(q)) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_l_msort_dw + + subroutine psi_l_amsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_lpk_) :: k(n) + integer(psb_lpk_) :: l(0:n+1) + ! + integer(psb_lpk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) <= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (abs(k(p)) > abs(k(q))) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (abs(k(p)) <= abs(k(q))) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) > abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_l_amsort_up + + subroutine psi_l_amsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_lpk_) :: k(n) + integer(psb_lpk_) :: l(0:n+1) + ! + integer(psb_lpk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) >= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (abs(k(p)) < abs(k(q))) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (abs(k(p)) >= abs(k(q))) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) < abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_l_amsort_dw + + + + + + + + diff --git a/base/serial/sort/psb_l_qsort_impl.f90 b/base/serial/sort/psb_l_qsort_impl.f90 new file mode 100644 index 000000000..f02428e20 --- /dev/null +++ b/base/serial/sort/psb_l_qsort_impl.f90 @@ -0,0 +1,1318 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_lqsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_lqsort + use psb_error_mod + implicit none + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_lpk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, err_act, i + integer(psb_lpk_) :: n + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_lqsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1,n + ix(i) = i + end do + end if + + select case(dir_) + case (psb_sort_up_) + call psi_lqsrx_up(n,x,ix) + case (psb_sort_down_) + call psi_lqsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_laqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_laqsrx_dw(n,x,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + else + select case(dir_) + case (psb_sort_up_) + call psi_lqsr_up(n,x) + case (psb_sort_down_) + call psi_lqsr_dw(n,x) + case (psb_asort_up_) + call psi_laqsr_up(n,x) + case (psb_asort_down_) + call psi_laqsr_dw(n,x) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_lqsort + +subroutine psi_lqsrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_lqsrx_up + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_lpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_lpk_) :: n1, n2 + integer(psb_lpk_) :: ixt + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_lqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_lisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_lisrx_up(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_lisrx_up(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_lisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_lisrx_up(n,x,idx) + endif +end subroutine psi_lqsrx_up + +subroutine psi_lqsrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_lqsrx_dw + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_lpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_lpk_) :: n1, n2 + integer(psb_lpk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_lqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_lisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_lisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_lisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_lisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_lisrx_dw(n,x,idx) + endif + +end subroutine psi_lqsrx_dw + +subroutine psi_lqsr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_lqsr_up + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_lpk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_lpk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_lqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_lisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_lisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_lisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_lisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_lisr_up(n,x) + endif + +end subroutine psi_lqsr_up + +subroutine psi_lqsr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_lqsr_dw + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_lpk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_lpk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_lqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_lisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_lisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_lisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_lisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_lisr_dw(n,x) + endif + +end subroutine psi_lqsr_dw + +subroutine psi_laqsrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_laqsrx_up + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_lpk_) :: piv, xk + integer(psb_lpk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_lpk_) :: n1, n2 + integer(psb_lpk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_laqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_laisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_laisrx_up(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_laisrx_up(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_laisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_laisrx_up(n,x,idx) + endif + + +end subroutine psi_laqsrx_up + +subroutine psi_laqsrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_laqsrx_dw + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: idx(:) + integer(psb_lpk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_lpk_) :: piv, xk + integer(psb_lpk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_lpk_) :: n1, n2 + integer(psb_lpk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_laqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_laisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_laisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_laisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_laisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_laisrx_dw(n,x,idx) + endif + +end subroutine psi_laqsrx_dw + +subroutine psi_laqsr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_laqsr_up + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_lpk_) :: piv, xk + integer(psb_lpk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_lpk_) :: n1, n2 + integer(psb_lpk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_lqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_laisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_laisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_laisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_laisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_laisr_up(n,x) + endif + +end subroutine psi_laqsr_up + +subroutine psi_laqsr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_laqsr_dw + use psb_error_mod + implicit none + + integer(psb_lpk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_lpk_) :: piv, xk + integer(psb_lpk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_lpk_) :: n1, n2 + integer(psb_lpk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_lqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_laisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_laisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_laisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_laisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_laisr_dw(n,x) + endif + +end subroutine psi_laqsr_dw + + diff --git a/base/serial/sort/psb_m_hsort_impl.f90 b/base/serial/sort/psb_m_hsort_impl.f90 new file mode 100644 index 000000000..dad772103 --- /dev/null +++ b/base/serial/sort/psb_m_hsort_impl.f90 @@ -0,0 +1,678 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The merge-sort and quicksort routines are implemented in the +! serial/aux directory +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_mhsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_mhsort + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info + integer(psb_mpk_) :: key + integer(psb_ipk_) :: index + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_hsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + select case(dir_) + case(psb_sort_up_,psb_sort_down_) + ! OK + case (psb_asort_up_,psb_asort_down_) + ! OK + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + ! + ! Dirty trick to sort with heaps: if we want + ! to sort in place upwards, first we set up a heap so that + ! we can easily get the LARGEST element, then we take it out + ! and put it in the last entry, and so on. + ! So, we invert dir_ + ! + dir_ = -dir_ + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_ == psb_sort_ovw_idx_) then + do i=1, n + ix(i) = i + end do + end if + l = 0 + do i=1, n + key = x(i) + index = ix(i) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ' + end if + end do + do i=n, 2, -1 + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + ix(i) = index + end do + else if (.not.present(ix)) then + l = 0 + do i=1, n + key = x(i) + call psi_insert_heap(key,l,x,dir_,info) + if (l /= i) then + write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i + end if + end do + do i=n, 2, -1 + call psi_m_heap_get_first(key,l,x,dir_,info) + if (l /= i-1) then + write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i + end if + x(i) = key + end do + end if + + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_mhsort + + + +! +! These are packaged so that they can be used to implement +! a heapsort, should the need arise +! +! +! Programming note: +! In the implementation of the heap_get_first function +! we have code like this +! +! if ( ( heap(2*i) < heap(2*i+1) ) .or.& +! & (2*i == last)) then +! j = 2*i +! else +! j = 2*i + 1 +! end if +! +! It looks like the 2*i+1 could overflow the array, but this +! is not true because there is a guard statement +! if (i>last/2) exit +! and because last has just been reduced by 1 when defining the return value, +! therefore 2*i+1 may be greater than the current value of last, +! but cannot be greater than the value of last when the routine was entered +! hence it is safe. +! +! +! + +subroutine psi_m_insert_heap(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_m_insert_heap + implicit none + + ! + ! Input: + ! key: the new value + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! dir: sorting direction + + integer(psb_mpk_), intent(in) :: key + integer(psb_ipk_), intent(in) :: dir + integer(psb_mpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2 + integer(psb_mpk_) :: temp + + info = psb_success_ + if (last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',last + info = last + return + endif + last = last + 1 + if (last > size(heap)) then + write(psb_err_unit,*) 'out of bounds ' + info = -1 + return + end if + i = last + heap(i) = key + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_m_insert_heap + + +subroutine psi_m_heap_get_first(key,last,heap,dir,info) + use psb_sort_mod, psb_protect_name => psi_m_heap_get_first + implicit none + + integer(psb_mpk_), intent(inout) :: key + integer(psb_ipk_), intent(inout) :: last + integer(psb_ipk_), intent(in) :: dir + integer(psb_mpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: i, j + integer(psb_mpk_) :: temp + + + info = psb_success_ + if (last <= 0) then + key = 0 + info = -1 + return + endif + + key = heap(1) + heap(1) = heap(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_m_heap_get_first + + +subroutine psi_m_idx_insert_heap(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_m_idx_insert_heap + + implicit none + ! + ! Input: + ! key: the new value + ! index: the new index + ! last: pointer to the last occupied element in heap + ! heap: the heap + ! idxs: the indices + ! dir: sorting direction + + integer(psb_mpk_), intent(in) :: key + integer(psb_ipk_), intent(in) :: index,dir + integer(psb_mpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(inout) :: idxs(:),last + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: i, i2, itemp + integer(psb_mpk_) :: temp + + info = psb_success_ + if (last < 0) then + write(psb_err_unit,*) 'Invalid last in heap ',last + info = last + return + endif + + last = last + 1 + if (last > size(heap)) then + write(psb_err_unit,*) 'out of bounds ' + info = -1 + return + end if + + i = last + heap(i) = key + idxs(i) = index + + select case(dir) + case (psb_sort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) < heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_sort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (heap(i) > heap(i2)) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + case (psb_asort_up_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) < abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case (psb_asort_down_) + + do + if (i<=1) exit + i2 = i/2 + if (abs(heap(i)) > abs(heap(i2))) then + itemp = idxs(i) + idxs(i) = idxs(i2) + idxs(i2) = itemp + temp = heap(i) + heap(i) = heap(i2) + heap(i2) = temp + i = i2 + else + exit + end if + end do + + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_m_idx_insert_heap + +subroutine psi_m_idx_heap_get_first(key,index,last,heap,idxs,dir,info) + use psb_sort_mod, psb_protect_name => psi_m_idx_heap_get_first + implicit none + + integer(psb_mpk_), intent(inout) :: heap(:) + integer(psb_ipk_), intent(out) :: index,info + integer(psb_ipk_), intent(inout) :: last,idxs(:) + integer(psb_ipk_), intent(in) :: dir + integer(psb_mpk_), intent(out) :: key + + integer(psb_ipk_) :: i, j,itemp + integer(psb_mpk_) :: temp + + info = psb_success_ + if (last <= 0) then + key = 0 + index = 0 + info = -1 + return + endif + + key = heap(1) + index = idxs(1) + heap(1) = heap(last) + idxs(1) = idxs(last) + last = last - 1 + + select case(dir) + case (psb_sort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) < heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) > heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_sort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (heap(2*i) > heap(2*i+1)) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (heap(i) < heap(j)) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case (psb_asort_up_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) < abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) > abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + + case (psb_asort_down_) + + i = 1 + do + if (i > (last/2)) exit + if ( (abs(heap(2*i)) > abs(heap(2*i+1))) .or.& + & (2*i == last)) then + j = 2*i + else + j = 2*i + 1 + end if + + if (abs(heap(i)) < abs(heap(j))) then + itemp = idxs(i) + idxs(i) = idxs(j) + idxs(j) = itemp + temp = heap(i) + heap(i) = heap(j) + heap(j) = temp + i = j + else + exit + end if + end do + + case default + write(psb_err_unit,*) 'Invalid direction in heap ',dir + end select + + return +end subroutine psi_m_idx_heap_get_first + + + + diff --git a/base/serial/sort/psb_m_isort_impl.f90 b/base/serial/sort/psb_m_isort_impl.f90 new file mode 100644 index 000000000..1f373e425 --- /dev/null +++ b/base/serial/sort/psb_m_isort_impl.f90 @@ -0,0 +1,341 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The insertion sort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_misort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_misort + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, err_act + integer(psb_ipk_) :: n, i + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_misort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1,n + ix(i) = i + end do + end if + + select case(dir_) + case (psb_sort_up_) + call psi_misrx_up(n,x,ix) + case (psb_sort_down_) + call psi_misrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_maisrx_up(n,x,ix) + case (psb_asort_down_) + call psi_maisrx_dw(n,x,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + else + select case(dir_) + case (psb_sort_up_) + call psi_misr_up(n,x) + case (psb_sort_down_) + call psi_misr_dw(n,x) + case (psb_asort_up_) + call psi_maisr_up(n,x) + case (psb_asort_down_) + call psi_maisr_dw(n,x) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_misort + +subroutine psi_misrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_misrx_up + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j,ix + integer(psb_mpk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_misrx_up + +subroutine psi_misrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_misrx_dw + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j,ix + integer(psb_mpk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_misrx_dw + + +subroutine psi_misr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_misr_up + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j + integer(psb_mpk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) < x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) >= xx) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_misr_up + +subroutine psi_misr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_misr_dw + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j + integer(psb_mpk_) :: xx + + do j=n-1,1,-1 + if (x(j+1) > x(j)) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (x(i) <= xx) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_misr_dw + +subroutine psi_maisrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_maisrx_up + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j,ix + integer(psb_mpk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= abs(xx)) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_maisrx_up + +subroutine psi_maisrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_maisrx_dw + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j,ix + integer(psb_mpk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + ix = idx(j) + i=j+1 + do + x(i-1) = x(i) + idx(i-1) = idx(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= abs(xx)) exit + end do + x(i-1) = xx + idx(i-1) = ix + endif + enddo +end subroutine psi_maisrx_dw + +subroutine psi_maisr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_maisr_up + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j + integer(psb_mpk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) < abs(x(j))) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) >= abs(xx)) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_maisr_up + +subroutine psi_maisr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_maisr_dw + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + integer(psb_ipk_) :: i,j + integer(psb_mpk_) :: xx + + do j=n-1,1,-1 + if (abs(x(j+1)) > abs(x(j))) then + xx = x(j) + i=j+1 + do + x(i-1) = x(i) + i = i+1 + if (i>n) exit + if (abs(x(i)) <= abs(xx)) exit + end do + x(i-1) = xx + endif + enddo +end subroutine psi_maisr_dw + diff --git a/base/serial/sort/psb_m_msort_impl.f90 b/base/serial/sort/psb_m_msort_impl.f90 new file mode 100644 index 000000000..abbe40495 --- /dev/null +++ b/base/serial/sort/psb_m_msort_impl.f90 @@ -0,0 +1,713 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! + ! + ! The merge-sort routines + ! References: + ! D. Knuth + ! The Art of Computer Programming, vol. 3 + ! Addison-Wesley + ! + ! Aho, Hopcroft, Ullman + ! Data Structures and Algorithms + ! Addison-Wesley + ! + logical function psb_misaperm(n,eip) + use psb_sort_mod, psb_protect_name => psb_misaperm + implicit none + + integer(psb_mpk_), intent(in) :: n + integer(psb_mpk_), intent(in) :: eip(n) + integer(psb_mpk_), allocatable :: ip(:) + integer(psb_mpk_) :: i,j,m, info + + + psb_misaperm = .true. + if (n <= 0) return + allocate(ip(n), stat=info) + if (info /= psb_success_) return + ! + ! sanity check first + ! + do i=1, n + ip(i) = eip(i) + if ((ip(i) < 1).or.(ip(i) > n)) then + write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n + psb_misaperm = .false. + return + endif + enddo + + ! + ! now work through the cycles, by marking each successive item as negative. + ! no cycle should intersect with any other, hence the >= 1 check. + ! + do m = 1, n + i = ip(m) + if (i < 0) then + ip(m) = -i + else if (i /= m) then + j = ip(i) + ip(i) = -j + i = j + do while ((j >= 1).and.(j /= m)) + j = ip(i) + ip(i) = -j + i = j + enddo + ip(m) = abs(ip(m)) + if (j /= m) then + psb_misaperm = .false. + goto 9999 + endif + end if + enddo +9999 continue + + return + end function psb_misaperm + + + subroutine psb_mmsort_u(x,nout,dir) + use psb_sort_mod, psb_protect_name => psb_mmsort_u + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: nout + integer(psb_ipk_), optional, intent(in) :: dir + + integer(psb_ipk_) :: n, k + integer(psb_ipk_) :: err_act + + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_msort_u' + call psb_erractionsave(err_act) + + n = size(x) + + call psb_msort(x,dir=dir) + nout = min(1,n) + do k=2,n + if (x(k) /= x(nout)) then + nout = nout + 1 + x(nout) = x(k) + endif + enddo + + return + +9999 call psb_error_handler(err_act) + + return + end subroutine psb_mmsort_u + + + function psb_mbsrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_mbsrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_mpk_) :: key + integer(psb_mpk_) :: v(:) + + integer(psb_ipk_) :: lb, ub, m, i + + ipos = -1 + if (n<5) then + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + return + end if + + lb = 1 + ub = n + + do while (lb.le.ub) + m = (lb+ub)/2 + if (key.eq.v(m)) then + ipos = m + lb = ub + 1 + else if (key < v(m)) then + ub = m-1 + else + lb = m + 1 + end if + enddo + return + end function psb_mbsrch + + function psb_mssrch(key,n,v) result(ipos) + use psb_sort_mod, psb_protect_name => psb_mssrch + implicit none + integer(psb_ipk_) :: ipos, n + integer(psb_mpk_) :: key + integer(psb_mpk_) :: v(:) + + integer(psb_ipk_) :: i + + ipos = -1 + do i=1,n + if (key.eq.v(i)) then + ipos = i + return + end if + enddo + + return + end function psb_mssrch + + subroutine psb_mmsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_mmsort + use psb_error_mod + use psb_ip_reord_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, n, err_act + + integer(psb_ipk_), allocatable :: iaux(:) + integer(psb_ipk_) :: iret, info, i + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_mmsort' + call psb_erractionsave(err_act) + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + select case(dir_) + case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_) + ! OK keep going + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case(psb_sort_ovw_idx_) + do i=1,n + ix(i) = i + end do + case (psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + allocate(iaux(0:n+1),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_m_msort') + goto 9999 + endif + + select case(dir_) + case (psb_sort_up_) + call psi_m_msort_up(n,x,iaux,iret) + case (psb_sort_down_) + call psi_m_msort_dw(n,x,iaux,iret) + case (psb_asort_up_) + call psi_m_amsort_up(n,x,iaux,iret) + case (psb_asort_down_) + call psi_m_amsort_dw(n,x,iaux,iret) + end select + ! + ! Do the actual reordering, since the inner routines + ! only provide linked pointers. + ! + if (iret == 0 ) then + if (present(ix)) then + call psb_ip_reord(n,x,ix,iaux) + else + call psb_ip_reord(n,x,iaux) + end if + end if + + + return + +9999 call psb_error_handler(err_act) + + return + + + end subroutine psb_mmsort + + subroutine psi_m_msort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) <= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) > k(q)) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) <= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) > k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_m_msort_up + + subroutine psi_m_msort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (k(p) >= k(p+1)) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (k(p) < k(q)) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (k(p) >= k(q)) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (k(p) < k(q)) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_m_msort_dw + + subroutine psi_m_amsort_up(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) <= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (abs(k(p)) > abs(k(q))) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (abs(k(p)) <= abs(k(q))) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) > abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_m_amsort_up + + subroutine psi_m_amsort_dw(n,k,l,iret) + use psb_const_mod + implicit none + integer(psb_ipk_) :: n, iret + integer(psb_mpk_) :: k(n) + integer(psb_ipk_) :: l(0:n+1) + ! + integer(psb_ipk_) :: p,q,s,t + ! .. + iret = 0 + ! first step: we are preparing ordered sublists, exploiting + ! what order was already in the input data; negative links + ! mark the end of the sublists + l(0) = 1 + t = n + 1 + do p = 1,n - 1 + if (abs(k(p)) >= abs(k(p+1))) then + l(p) = p + 1 + else + l(t) = - (p+1) + t = p + end if + end do + l(t) = 0 + l(n) = 0 + ! see if the input was already sorted + if (l(n+1) == 0) then + iret = 1 + return + else + l(n+1) = abs(l(n+1)) + end if + + mergepass: do + ! otherwise, begin a pass through the list. + ! throughout all the subroutine we have: + ! p, q: pointing to the sublists being merged + ! s: pointing to the most recently processed record + ! t: pointing to the end of previously completed sublist + s = 0 + t = n + 1 + p = l(s) + q = l(t) + if (q == 0) exit mergepass + + outer: do + + if (abs(k(p)) < abs(k(q))) then + + l(s) = sign(q,l(s)) + s = q + q = l(q) + if (q > 0) then + do + if (abs(k(p)) >= abs(k(q))) cycle outer + s = q + q = l(q) + if (q <= 0) exit + end do + end if + l(s) = p + s = t + do + t = p + p = l(p) + if (p <= 0) exit + end do + + else + + l(s) = sign(p,l(s)) + s = p + p = l(p) + if (p>0) then + do + if (abs(k(p)) < abs(k(q))) cycle outer + s = p + p = l(p) + if (p <= 0) exit + end do + end if + ! otherwise, one sublist ended, and we append to it the rest + ! of the other one. + l(s) = q + s = t + do + t = q + q = l(q) + if (q <= 0) exit + end do + end if + + p = -p + q = -q + if (q == 0) then + l(s) = sign(p,l(s)) + l(t) = 0 + exit outer + end if + end do outer + end do mergepass + + end subroutine psi_m_amsort_dw + + + + + + + + diff --git a/base/serial/sort/psb_m_qsort_impl.f90 b/base/serial/sort/psb_m_qsort_impl.f90 new file mode 100644 index 000000000..ac8241f59 --- /dev/null +++ b/base/serial/sort/psb_m_qsort_impl.f90 @@ -0,0 +1,1318 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! The quicksort routines +! References: +! D. Knuth +! The Art of Computer Programming, vol. 3 +! Addison-Wesley +! +! Aho, Hopcroft, Ullman +! Data Structures and Algorithms +! Addison-Wesley +! +subroutine psb_mqsort(x,ix,dir,flag) + use psb_sort_mod, psb_protect_name => psb_mqsort + use psb_error_mod + implicit none + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), optional, intent(in) :: dir, flag + integer(psb_ipk_), optional, intent(inout) :: ix(:) + + integer(psb_ipk_) :: dir_, flag_, err_act, i + integer(psb_ipk_) :: n + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name + + name='psb_mqsort' + call psb_erractionsave(err_act) + + if (present(flag)) then + flag_ = flag + else + flag_ = psb_sort_ovw_idx_ + end if + select case(flag_) + case( psb_sort_ovw_idx_, psb_sort_keep_idx_) + ! OK keep going + case default + ierr(1) = 4; ierr(2) = flag_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + if (present(dir)) then + dir_ = dir + else + dir_= psb_sort_up_ + end if + + n = size(x) + + if (present(ix)) then + if (size(ix) < n) then + ierr(1) = 2; ierr(2) = size(ix); + call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr) + goto 9999 + end if + if (flag_==psb_sort_ovw_idx_) then + do i=1,n + ix(i) = i + end do + end if + + select case(dir_) + case (psb_sort_up_) + call psi_mqsrx_up(n,x,ix) + case (psb_sort_down_) + call psi_mqsrx_dw(n,x,ix) + case (psb_asort_up_) + call psi_maqsrx_up(n,x,ix) + case (psb_asort_down_) + call psi_maqsrx_dw(n,x,ix) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + else + select case(dir_) + case (psb_sort_up_) + call psi_mqsr_up(n,x) + case (psb_sort_down_) + call psi_mqsr_dw(n,x) + case (psb_asort_up_) + call psi_maqsr_up(n,x) + case (psb_asort_down_) + call psi_maqsr_dw(n,x) + case default + ierr(1) = 3; ierr(2) = dir_; + call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr) + goto 9999 + end select + + end if + + return + +9999 call psb_error_handler(err_act) + + return +end subroutine psb_mqsort + +subroutine psi_mqsrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_mqsrx_up + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_mpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_mqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_misrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_misrx_up(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_misrx_up(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_misrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_misrx_up(n,x,idx) + endif +end subroutine psi_mqsrx_up + +subroutine psi_mqsrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_mqsrx_dw + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_mpk_) :: piv, xk, xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = x(lpiv) + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_mqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_misrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_misrx_dw(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_misrx_dw(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_misrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_misrx_dw(n,x,idx) + endif + +end subroutine psi_mqsrx_dw + +subroutine psi_mqsr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_mqsr_up + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_mpk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = x(i) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_up2:do + j = j - 1 + xk = x(j) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_mqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_misr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_misr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_misr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_misr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_misr_up(n,x) + endif + +end subroutine psi_mqsr_up + +subroutine psi_mqsr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_mqsr_dw + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. + ! .. Local Scalars .. + integer(psb_mpk_) :: piv, xt, xk + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = x(lpiv) + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv < x(j)) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + if (piv > x(i)) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = x(lpiv) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = x(i) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = xk + x(i) = piv + in_dw2:do + j = j - 1 + xk = x(j) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_mqsr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_misr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_misr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_misr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_misr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_misr_dw(n,x) + endif + +end subroutine psi_mqsr_dw + +subroutine psi_maqsrx_up(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_maqsrx_up + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_mpk_) :: piv, xk + integer(psb_mpk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_maqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_maisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_maisrx_up(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_maisrx_up(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_maisrx_up(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_maisrx_up(n,x,idx) + endif + + +end subroutine psi_maqsrx_up + +subroutine psi_maqsrx_dw(n,x,idx) + use psb_sort_mod, psb_protect_name => psi_maqsrx_dw + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(inout) :: idx(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_mpk_) :: piv, xk + integer(psb_mpk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + ixt = idx(j) + x(j) = x(lpiv) + idx(j) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + xt = x(i) + ixt = idx(i) + x(i) = x(lpiv) + idx(i) = idx(lpiv) + x(lpiv) = xt + idx(lpiv) = ixt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + ixt = idx(i) + x(i) = x(j) + idx(i) = idx(j) + x(j) = xt + idx(j) = ixt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_maqsrx',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_maisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_maisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_maisrx_dw(n2,x(i:iux),idx(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_maisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1)) + endif + endif + enddo + else + call psi_maisrx_dw(n,x,idx) + endif + +end subroutine psi_maqsrx_dw + +subroutine psi_maqsr_up(n,x) + use psb_sort_mod, psb_protect_name => psi_maqsr_up + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_mpk_) :: piv, xk + integer(psb_mpk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_up: do + in_up1: do + i = i + 1 + xk = abs(x(i)) + if (xk >= piv) exit in_up1 + end do in_up1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_up2:do + j = j - 1 + xk = abs(x(j)) + if (xk <= piv) exit in_up2 + end do in_up2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_up + end if + end do outer_up + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_, & + & r_name='psi_mqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_maisr_up(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_maisr_up(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_maisr_up(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_maisr_up(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_maisr_up(n,x) + endif + +end subroutine psi_maqsr_up + +subroutine psi_maqsr_dw(n,x) + use psb_sort_mod, psb_protect_name => psi_maqsr_dw + use psb_error_mod + implicit none + + integer(psb_mpk_), intent(inout) :: x(:) + integer(psb_ipk_), intent(in) :: n + ! .. Local Scalars .. + integer(psb_mpk_) :: piv, xk + integer(psb_mpk_) :: xt + integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt + + integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 + integer(psb_ipk_) :: istack(nparms,maxstack) + + if (n > ithrs) then + ! + ! Init stack pointer + ! + istp = 1 + istack(1,istp) = 1 + istack(2,istp) = n + + do + if (istp <= 0) exit + ilx = istack(1,istp) + iux = istack(2,istp) + istp = istp - 1 + ! + ! Choose a pivot with median-of-three heuristics, leave it + ! in the LPIV location + ! + i = ilx + j = iux + lpiv = (i+j)/2 + piv = abs(x(lpiv)) + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv < abs(x(j))) then + xt = x(j) + x(j) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + if (piv > abs(x(i))) then + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + piv = abs(x(lpiv)) + endif + ! + ! now piv is correct; place it into first location + + xt = x(i) + x(i) = x(lpiv) + x(lpiv) = xt + + i = ilx - 1 + j = iux + 1 + + outer_dw: do + in_dw1: do + i = i + 1 + xk = abs(x(i)) + if (xk <= piv) exit in_dw1 + end do in_dw1 + ! + ! Ensure finite termination for next loop + ! + xt = x(i) + x(i) = piv + in_dw2:do + j = j - 1 + xk = abs(x(j)) + if (xk >= piv) exit in_dw2 + end do in_dw2 + x(i) = xt + + if (j > i) then + xt = x(i) + x(i) = x(j) + x(j) = xt + else + exit outer_dw + end if + end do outer_dw + if (i == ilx) then + if (x(i) /= piv) then + call psb_errpush(psb_err_internal_error_,& + & r_name='psi_mqasr',a_err='impossible pivot condition') + call psb_error() + endif + i = i + 1 + endif + + n1 = (i-1)-ilx+1 + n2 = iux-(i)+1 + if (n1 > n2) then + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_maisr_dw(n1,x(ilx:i-1)) + endif + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_maisr_dw(n2,x(i:iux)) + endif + else + if (n2 > ithrs) then + istp = istp + 1 + istack(1,istp) = i + istack(2,istp) = iux + else + call psi_maisr_dw(n2,x(i:iux)) + endif + if (n1 > ithrs) then + istp = istp + 1 + istack(1,istp) = ilx + istack(2,istp) = i-1 + else + call psi_maisr_dw(n1,x(ilx:i-1)) + endif + endif + enddo + else + call psi_maisr_dw(n,x) + endif + +end subroutine psi_maqsr_dw + + diff --git a/base/serial/sort/psb_s_hsort_impl.f90 b/base/serial/sort/psb_s_hsort_impl.f90 index 12a7c7a1c..4737d1591 100644 --- a/base/serial/sort/psb_s_hsort_impl.f90 +++ b/base/serial/sort/psb_s_hsort_impl.f90 @@ -42,7 +42,7 @@ ! Addison-Wesley ! subroutine psb_shsort(x,ix,dir,flag) - use psb_s_sort_mod, psb_protect_name => psb_shsort + use psb_sort_mod, psb_protect_name => psb_shsort use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -116,13 +116,13 @@ subroutine psb_shsort(x,ix,dir,flag) do i=1, n key = x(i) index = ix(i) - call psi_s_idx_insert_heap(key,index,l,x,ix,dir_,info) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ' end if end do do i=n, 2, -1 - call psi_s_idx_heap_get_first(key,index,l,x,ix,dir_,info) + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) if (l /= i-1) then write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i end if @@ -133,7 +133,7 @@ subroutine psb_shsort(x,ix,dir,flag) l = 0 do i=1, n key = x(i) - call psi_s_insert_heap(key,l,x,dir_,info) + call psi_insert_heap(key,l,x,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i end if @@ -185,7 +185,7 @@ end subroutine psb_shsort ! subroutine psi_s_insert_heap(key,last,heap,dir,info) - use psb_s_sort_mod, psb_protect_name => psi_s_insert_heap + use psb_sort_mod, psb_protect_name => psi_s_insert_heap implicit none ! @@ -291,7 +291,7 @@ end subroutine psi_s_insert_heap subroutine psi_s_heap_get_first(key,last,heap,dir,info) - use psb_s_sort_mod, psb_protect_name => psi_s_heap_get_first + use psb_sort_mod, psb_protect_name => psi_s_heap_get_first implicit none real(psb_spk_), intent(inout) :: key @@ -415,7 +415,7 @@ end subroutine psi_s_heap_get_first subroutine psi_s_idx_insert_heap(key,index,last,heap,idxs,dir,info) - use psb_s_sort_mod, psb_protect_name => psi_s_idx_insert_heap + use psb_sort_mod, psb_protect_name => psi_s_idx_insert_heap implicit none ! @@ -537,7 +537,7 @@ subroutine psi_s_idx_insert_heap(key,index,last,heap,idxs,dir,info) end subroutine psi_s_idx_insert_heap subroutine psi_s_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - use psb_s_sort_mod, psb_protect_name => psi_s_idx_heap_get_first + use psb_sort_mod, psb_protect_name => psi_s_idx_heap_get_first implicit none real(psb_spk_), intent(inout) :: heap(:) diff --git a/base/serial/sort/psb_s_isort_impl.f90 b/base/serial/sort/psb_s_isort_impl.f90 index fbac121b8..cdcc05eb5 100644 --- a/base/serial/sort/psb_s_isort_impl.f90 +++ b/base/serial/sort/psb_s_isort_impl.f90 @@ -41,14 +41,15 @@ ! Addison-Wesley ! subroutine psb_sisort(x,ix,dir,flag) - use psb_s_sort_mod, psb_protect_name => psb_sisort + use psb_sort_mod, psb_protect_name => psb_sisort use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i + integer(psb_ipk_) :: dir_, flag_, err_act + integer(psb_ipk_) :: n, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -130,7 +131,7 @@ subroutine psb_sisort(x,ix,dir,flag) end subroutine psb_sisort subroutine psi_sisrx_up(n,x,idx) - use psb_s_sort_mod, psb_protect_name => psi_sisrx_up + use psb_sort_mod, psb_protect_name => psi_sisrx_up use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -158,7 +159,7 @@ subroutine psi_sisrx_up(n,x,idx) end subroutine psi_sisrx_up subroutine psi_sisrx_dw(n,x,idx) - use psb_s_sort_mod, psb_protect_name => psi_sisrx_dw + use psb_sort_mod, psb_protect_name => psi_sisrx_dw use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -187,7 +188,7 @@ end subroutine psi_sisrx_dw subroutine psi_sisr_up(n,x) - use psb_s_sort_mod, psb_protect_name => psi_sisr_up + use psb_sort_mod, psb_protect_name => psi_sisr_up use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -211,7 +212,7 @@ subroutine psi_sisr_up(n,x) end subroutine psi_sisr_up subroutine psi_sisr_dw(n,x) - use psb_s_sort_mod, psb_protect_name => psi_sisr_dw + use psb_sort_mod, psb_protect_name => psi_sisr_dw use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -235,7 +236,7 @@ subroutine psi_sisr_dw(n,x) end subroutine psi_sisr_dw subroutine psi_saisrx_up(n,x,idx) - use psb_s_sort_mod, psb_protect_name => psi_saisrx_up + use psb_sort_mod, psb_protect_name => psi_saisrx_up use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -263,7 +264,7 @@ subroutine psi_saisrx_up(n,x,idx) end subroutine psi_saisrx_up subroutine psi_saisrx_dw(n,x,idx) - use psb_s_sort_mod, psb_protect_name => psi_saisrx_dw + use psb_sort_mod, psb_protect_name => psi_saisrx_dw use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -291,7 +292,7 @@ subroutine psi_saisrx_dw(n,x,idx) end subroutine psi_saisrx_dw subroutine psi_saisr_up(n,x) - use psb_s_sort_mod, psb_protect_name => psi_saisr_up + use psb_sort_mod, psb_protect_name => psi_saisr_up use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -315,7 +316,7 @@ subroutine psi_saisr_up(n,x) end subroutine psi_saisr_up subroutine psi_saisr_dw(n,x) - use psb_s_sort_mod, psb_protect_name => psi_saisr_dw + use psb_sort_mod, psb_protect_name => psi_saisr_dw use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) diff --git a/base/serial/sort/psb_s_msort_impl.f90 b/base/serial/sort/psb_s_msort_impl.f90 index 3b3732912..a1af2f569 100644 --- a/base/serial/sort/psb_s_msort_impl.f90 +++ b/base/serial/sort/psb_s_msort_impl.f90 @@ -42,7 +42,7 @@ ! subroutine psb_smsort_u(x,nout,dir) - use psb_s_sort_mod, psb_protect_name => psb_smsort_u + use psb_sort_mod, psb_protect_name => psb_smsort_u use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) @@ -78,7 +78,7 @@ function psb_sbsrch(key,n,v) result(ipos) - use psb_s_sort_mod, psb_protect_name => psb_sbsrch + use psb_sort_mod, psb_protect_name => psb_sbsrch implicit none integer(psb_ipk_) :: ipos, n real(psb_spk_) :: key @@ -115,7 +115,7 @@ end function psb_sbsrch function psb_sssrch(key,n,v) result(ipos) - use psb_s_sort_mod, psb_protect_name => psb_sssrch + use psb_sort_mod, psb_protect_name => psb_sssrch implicit none integer(psb_ipk_) :: ipos, n real(psb_spk_) :: key @@ -135,7 +135,7 @@ end function psb_sssrch subroutine psb_smsort(x,ix,dir,flag) - use psb_s_sort_mod, psb_protect_name => psb_smsort + use psb_sort_mod, psb_protect_name => psb_smsort use psb_error_mod use psb_ip_reord_mod implicit none diff --git a/base/serial/sort/psb_s_qsort_impl.f90 b/base/serial/sort/psb_s_qsort_impl.f90 index 7110fa4fc..d6e0e66e7 100644 --- a/base/serial/sort/psb_s_qsort_impl.f90 +++ b/base/serial/sort/psb_s_qsort_impl.f90 @@ -41,15 +41,15 @@ ! Addison-Wesley ! subroutine psb_sqsort(x,ix,dir,flag) - use psb_s_sort_mod, psb_protect_name => psb_sqsort + use psb_sort_mod, psb_protect_name => psb_sqsort use psb_error_mod implicit none real(psb_spk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i - + integer(psb_ipk_) :: dir_, flag_, err_act, i + integer(psb_ipk_) :: n integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -130,7 +130,7 @@ subroutine psb_sqsort(x,ix,dir,flag) end subroutine psb_sqsort subroutine psi_sqsrx_up(n,x,idx) - use psb_s_sort_mod, psb_protect_name => psi_sqsrx_up + use psb_sort_mod, psb_protect_name => psi_sqsrx_up use psb_error_mod implicit none @@ -140,7 +140,8 @@ subroutine psi_sqsrx_up(n,x,idx) ! .. Local Scalars .. real(psb_spk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -283,7 +284,7 @@ subroutine psi_sqsrx_up(n,x,idx) end subroutine psi_sqsrx_up subroutine psi_sqsrx_dw(n,x,idx) - use psb_s_sort_mod, psb_protect_name => psi_sqsrx_dw + use psb_sort_mod, psb_protect_name => psi_sqsrx_dw use psb_error_mod implicit none @@ -293,7 +294,8 @@ subroutine psi_sqsrx_dw(n,x,idx) ! .. Local Scalars .. real(psb_spk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -438,7 +440,7 @@ subroutine psi_sqsrx_dw(n,x,idx) end subroutine psi_sqsrx_dw subroutine psi_sqsr_up(n,x) - use psb_s_sort_mod, psb_protect_name => psi_sqsr_up + use psb_sort_mod, psb_protect_name => psi_sqsr_up use psb_error_mod implicit none @@ -579,7 +581,7 @@ subroutine psi_sqsr_up(n,x) end subroutine psi_sqsr_up subroutine psi_sqsr_dw(n,x) - use psb_s_sort_mod, psb_protect_name => psi_sqsr_dw + use psb_sort_mod, psb_protect_name => psi_sqsr_dw use psb_error_mod implicit none @@ -720,7 +722,7 @@ subroutine psi_sqsr_dw(n,x) end subroutine psi_sqsr_dw subroutine psi_saqsrx_up(n,x,idx) - use psb_s_sort_mod, psb_protect_name => psi_saqsrx_up + use psb_sort_mod, psb_protect_name => psi_saqsrx_up use psb_error_mod implicit none @@ -731,7 +733,8 @@ subroutine psi_saqsrx_up(n,x,idx) real(psb_spk_) :: piv, xk real(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -876,7 +879,7 @@ subroutine psi_saqsrx_up(n,x,idx) end subroutine psi_saqsrx_up subroutine psi_saqsrx_dw(n,x,idx) - use psb_s_sort_mod, psb_protect_name => psi_saqsrx_dw + use psb_sort_mod, psb_protect_name => psi_saqsrx_dw use psb_error_mod implicit none @@ -887,7 +890,8 @@ subroutine psi_saqsrx_dw(n,x,idx) real(psb_spk_) :: piv, xk real(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1030,7 +1034,7 @@ subroutine psi_saqsrx_dw(n,x,idx) end subroutine psi_saqsrx_dw subroutine psi_saqsr_up(n,x) - use psb_s_sort_mod, psb_protect_name => psi_saqsr_up + use psb_sort_mod, psb_protect_name => psi_saqsr_up use psb_error_mod implicit none @@ -1040,7 +1044,8 @@ subroutine psi_saqsr_up(n,x) real(psb_spk_) :: piv, xk real(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1170,7 +1175,7 @@ subroutine psi_saqsr_up(n,x) end subroutine psi_saqsr_up subroutine psi_saqsr_dw(n,x) - use psb_s_sort_mod, psb_protect_name => psi_saqsr_dw + use psb_sort_mod, psb_protect_name => psi_saqsr_dw use psb_error_mod implicit none @@ -1180,7 +1185,8 @@ subroutine psi_saqsr_dw(n,x) real(psb_spk_) :: piv, xk real(psb_spk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=72 integer(psb_ipk_) :: istack(nparms,maxstack) diff --git a/base/serial/sort/psb_z_hsort_impl.f90 b/base/serial/sort/psb_z_hsort_impl.f90 index af20205bd..7223e2115 100644 --- a/base/serial/sort/psb_z_hsort_impl.f90 +++ b/base/serial/sort/psb_z_hsort_impl.f90 @@ -42,7 +42,7 @@ ! Addison-Wesley ! subroutine psb_zhsort(x,ix,dir,flag) - use psb_z_sort_mod, psb_protect_name => psb_zhsort + use psb_sort_mod, psb_protect_name => psb_zhsort use psb_error_mod implicit none complex(psb_dpk_), intent(inout) :: x(:) @@ -116,13 +116,13 @@ subroutine psb_zhsort(x,ix,dir,flag) do i=1, n key = x(i) index = ix(i) - call psi_z_idx_insert_heap(key,index,l,x,ix,dir_,info) + call psi_idx_insert_heap(key,index,l,x,ix,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ' end if end do do i=n, 2, -1 - call psi_z_idx_heap_get_first(key,index,l,x,ix,dir_,info) + call psi_idx_heap_get_first(key,index,l,x,ix,dir_,info) if (l /= i-1) then write(psb_err_unit,*) 'Mismatch while pulling out of heap ',l,i end if @@ -133,7 +133,7 @@ subroutine psb_zhsort(x,ix,dir,flag) l = 0 do i=1, n key = x(i) - call psi_z_insert_heap(key,l,x,dir_,info) + call psi_insert_heap(key,l,x,dir_,info) if (l /= i) then write(psb_err_unit,*) 'Mismatch while heapifying ! ',l,i end if @@ -185,7 +185,7 @@ end subroutine psb_zhsort ! subroutine psi_z_insert_heap(key,last,heap,dir,info) - use psb_z_sort_mod, psb_protect_name => psi_z_insert_heap + use psb_sort_mod, psb_protect_name => psi_z_insert_heap implicit none ! @@ -391,7 +391,7 @@ contains end subroutine psi_z_insert_heap subroutine psi_z_heap_get_first(key,last,heap,dir,info) - use psb_z_sort_mod, psb_protect_name => psi_z_heap_get_first + use psb_sort_mod, psb_protect_name => psi_z_heap_get_first implicit none ! @@ -633,7 +633,7 @@ contains end subroutine psi_z_heap_get_first subroutine psi_z_idx_insert_heap(key,index,last,heap,idxs,dir,info) - use psb_z_sort_mod, psb_protect_name => psi_z_idx_insert_heap + use psb_sort_mod, psb_protect_name => psi_z_idx_insert_heap implicit none ! @@ -869,7 +869,7 @@ end subroutine psi_z_idx_insert_heap subroutine psi_z_idx_heap_get_first(key,index,last,heap,idxs,dir,info) - use psb_z_sort_mod, psb_protect_name => psi_z_idx_heap_get_first + use psb_sort_mod, psb_protect_name => psi_z_idx_heap_get_first implicit none ! diff --git a/base/serial/sort/psb_z_isort_impl.f90 b/base/serial/sort/psb_z_isort_impl.f90 index 98cc055ee..340ed8e31 100644 --- a/base/serial/sort/psb_z_isort_impl.f90 +++ b/base/serial/sort/psb_z_isort_impl.f90 @@ -41,14 +41,15 @@ ! Addison-Wesley ! subroutine psb_zisort(x,ix,dir,flag) - use psb_z_sort_mod, psb_protect_name => psb_zisort + use psb_sort_mod, psb_protect_name => psb_zisort use psb_error_mod implicit none complex(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i + integer(psb_ipk_) :: dir_, flag_, err_act + integer(psb_ipk_) :: n, i integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -138,7 +139,7 @@ subroutine psb_zisort(x,ix,dir,flag) end subroutine psb_zisort subroutine psi_zlisrx_up(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zlisrx_up + use psb_sort_mod, psb_protect_name => psi_zlisrx_up use psb_error_mod use psi_lcx_mod implicit none @@ -168,7 +169,7 @@ subroutine psi_zlisrx_up(n,x,idx) end subroutine psi_zlisrx_up subroutine psi_zlisrx_dw(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zlisrx_dw + use psb_sort_mod, psb_protect_name => psi_zlisrx_dw use psb_error_mod use psi_lcx_mod implicit none @@ -197,7 +198,7 @@ subroutine psi_zlisrx_dw(n,x,idx) end subroutine psi_zlisrx_dw subroutine psi_zlisr_up(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zlisr_up + use psb_sort_mod, psb_protect_name => psi_zlisr_up use psb_error_mod use psi_lcx_mod implicit none @@ -222,7 +223,7 @@ subroutine psi_zlisr_up(n,x) end subroutine psi_zlisr_up subroutine psi_zlisr_dw(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zlisr_dw + use psb_sort_mod, psb_protect_name => psi_zlisr_dw use psb_error_mod use psi_lcx_mod implicit none @@ -247,7 +248,7 @@ subroutine psi_zlisr_dw(n,x) end subroutine psi_zlisr_dw subroutine psi_zalisrx_up(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zalisrx_up + use psb_sort_mod, psb_protect_name => psi_zalisrx_up use psb_error_mod use psi_alcx_mod implicit none @@ -276,7 +277,7 @@ subroutine psi_zalisrx_up(n,x,idx) end subroutine psi_zalisrx_up subroutine psi_zalisrx_dw(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zalisrx_dw + use psb_sort_mod, psb_protect_name => psi_zalisrx_dw use psb_error_mod use psi_alcx_mod implicit none @@ -305,7 +306,7 @@ subroutine psi_zalisrx_dw(n,x,idx) end subroutine psi_zalisrx_dw subroutine psi_zalisr_up(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zalisr_up + use psb_sort_mod, psb_protect_name => psi_zalisr_up use psb_error_mod use psi_alcx_mod implicit none @@ -330,7 +331,7 @@ subroutine psi_zalisr_up(n,x) end subroutine psi_zalisr_up subroutine psi_zalisr_dw(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zalisr_dw + use psb_sort_mod, psb_protect_name => psi_zalisr_dw use psb_error_mod use psi_alcx_mod implicit none @@ -355,7 +356,7 @@ subroutine psi_zalisr_dw(n,x) end subroutine psi_zalisr_dw subroutine psi_zaisrx_up(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zaisrx_up + use psb_sort_mod, psb_protect_name => psi_zaisrx_up use psb_error_mod implicit none complex(psb_dpk_), intent(inout) :: x(:) @@ -383,7 +384,7 @@ subroutine psi_zaisrx_up(n,x,idx) end subroutine psi_zaisrx_up subroutine psi_zaisrx_dw(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zaisrx_dw + use psb_sort_mod, psb_protect_name => psi_zaisrx_dw use psb_error_mod implicit none complex(psb_dpk_), intent(inout) :: x(:) @@ -411,7 +412,7 @@ subroutine psi_zaisrx_dw(n,x,idx) end subroutine psi_zaisrx_dw subroutine psi_zaisr_up(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zaisr_up + use psb_sort_mod, psb_protect_name => psi_zaisr_up use psb_error_mod implicit none complex(psb_dpk_), intent(inout) :: x(:) @@ -435,7 +436,7 @@ subroutine psi_zaisr_up(n,x) end subroutine psi_zaisr_up subroutine psi_zaisr_dw(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zaisr_dw + use psb_sort_mod, psb_protect_name => psi_zaisr_dw use psb_error_mod implicit none complex(psb_dpk_), intent(inout) :: x(:) diff --git a/base/serial/sort/psb_z_msort_impl.f90 b/base/serial/sort/psb_z_msort_impl.f90 index 201556f96..e885176ec 100644 --- a/base/serial/sort/psb_z_msort_impl.f90 +++ b/base/serial/sort/psb_z_msort_impl.f90 @@ -42,7 +42,7 @@ ! subroutine psb_zmsort_u(x,nout,dir) - use psb_z_sort_mod, psb_protect_name => psb_zmsort_u + use psb_sort_mod, psb_protect_name => psb_zmsort_u use psb_error_mod implicit none complex(psb_dpk_), intent(inout) :: x(:) @@ -84,7 +84,7 @@ subroutine psb_zmsort(x,ix,dir,flag) - use psb_z_sort_mod, psb_protect_name => psb_zmsort + use psb_sort_mod, psb_protect_name => psb_zmsort use psb_error_mod use psb_ip_reord_mod implicit none diff --git a/base/serial/sort/psb_z_qsort_impl.f90 b/base/serial/sort/psb_z_qsort_impl.f90 index cdb58dccd..7b0af1c5d 100644 --- a/base/serial/sort/psb_z_qsort_impl.f90 +++ b/base/serial/sort/psb_z_qsort_impl.f90 @@ -41,15 +41,15 @@ ! Addison-Wesley ! subroutine psb_zqsort(x,ix,dir,flag) - use psb_z_sort_mod, psb_protect_name => psb_zqsort + use psb_sort_mod, psb_protect_name => psb_zqsort use psb_error_mod implicit none complex(psb_dpk_), intent(inout) :: x(:) integer(psb_ipk_), optional, intent(in) :: dir, flag integer(psb_ipk_), optional, intent(inout) :: ix(:) - integer(psb_ipk_) :: dir_, flag_, n, err_act, i - + integer(psb_ipk_) :: dir_, flag_, err_act, i + integer(psb_ipk_) :: n integer(psb_ipk_) :: ierr(5) character(len=20) :: name @@ -139,7 +139,7 @@ end subroutine psb_zqsort subroutine psi_zlqsrx_up(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zlqsrx_up + use psb_sort_mod, psb_protect_name => psi_zlqsrx_up use psb_error_mod use psi_lcx_mod implicit none @@ -150,7 +150,8 @@ subroutine psi_zlqsrx_up(n,x,idx) ! .. Local Scalars .. complex(psb_dpk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=24 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -295,7 +296,7 @@ subroutine psi_zlqsrx_up(n,x,idx) end subroutine psi_zlqsrx_up subroutine psi_zlqsrx_dw(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zlqsrx_dw + use psb_sort_mod, psb_protect_name => psi_zlqsrx_dw use psb_error_mod use psi_lcx_mod implicit none @@ -306,7 +307,8 @@ subroutine psi_zlqsrx_dw(n,x,idx) ! .. Local Scalars .. complex(psb_dpk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=24 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -450,7 +452,7 @@ subroutine psi_zlqsrx_dw(n,x,idx) end subroutine psi_zlqsrx_dw subroutine psi_zlqsr_up(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zlqsr_up + use psb_sort_mod, psb_protect_name => psi_zlqsr_up use psb_error_mod use psi_lcx_mod implicit none @@ -592,7 +594,7 @@ subroutine psi_zlqsr_up(n,x) end subroutine psi_zlqsr_up subroutine psi_zlqsr_dw(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zlqsr_dw + use psb_sort_mod, psb_protect_name => psi_zlqsr_dw use psb_error_mod use psi_lcx_mod implicit none @@ -733,7 +735,7 @@ subroutine psi_zlqsr_dw(n,x) end subroutine psi_zlqsr_dw subroutine psi_zalqsrx_up(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zalqsrx_up + use psb_sort_mod, psb_protect_name => psi_zalqsrx_up use psb_error_mod use psi_alcx_mod implicit none @@ -744,7 +746,8 @@ subroutine psi_zalqsrx_up(n,x,idx) ! .. Local Scalars .. complex(psb_dpk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=24 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -888,7 +891,7 @@ subroutine psi_zalqsrx_up(n,x,idx) end subroutine psi_zalqsrx_up subroutine psi_zalqsrx_dw(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zalqsrx_dw + use psb_sort_mod, psb_protect_name => psi_zalqsrx_dw use psb_error_mod use psi_alcx_mod implicit none @@ -899,7 +902,8 @@ subroutine psi_zalqsrx_dw(n,x,idx) ! .. Local Scalars .. complex(psb_dpk_) :: piv, xk, xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=24 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1043,7 +1047,7 @@ subroutine psi_zalqsrx_dw(n,x,idx) end subroutine psi_zalqsrx_dw subroutine psi_zalqsr_up(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zalqsr_up + use psb_sort_mod, psb_protect_name => psi_zalqsr_up use psb_error_mod use psi_alcx_mod implicit none @@ -1184,7 +1188,7 @@ subroutine psi_zalqsr_up(n,x) end subroutine psi_zalqsr_up subroutine psi_zalqsr_dw(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zalqsr_dw + use psb_sort_mod, psb_protect_name => psi_zalqsr_dw use psb_error_mod use psi_alcx_mod implicit none @@ -1324,7 +1328,7 @@ subroutine psi_zalqsr_dw(n,x) end subroutine psi_zalqsr_dw subroutine psi_zaqsrx_up(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zaqsrx_up + use psb_sort_mod, psb_protect_name => psi_zaqsrx_up use psb_error_mod implicit none @@ -1335,7 +1339,8 @@ subroutine psi_zaqsrx_up(n,x,idx) real(psb_dpk_) :: piv, xk complex(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=24 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1480,7 +1485,7 @@ subroutine psi_zaqsrx_up(n,x,idx) end subroutine psi_zaqsrx_up subroutine psi_zaqsrx_dw(n,x,idx) - use psb_z_sort_mod, psb_protect_name => psi_zaqsrx_dw + use psb_sort_mod, psb_protect_name => psi_zaqsrx_dw use psb_error_mod implicit none @@ -1491,7 +1496,8 @@ subroutine psi_zaqsrx_dw(n,x,idx) real(psb_dpk_) :: piv, xk complex(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=24 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1634,7 +1640,7 @@ subroutine psi_zaqsrx_dw(n,x,idx) end subroutine psi_zaqsrx_dw subroutine psi_zaqsr_up(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zaqsr_up + use psb_sort_mod, psb_protect_name => psi_zaqsr_up use psb_error_mod implicit none @@ -1644,7 +1650,8 @@ subroutine psi_zaqsr_up(n,x) real(psb_dpk_) :: piv, xk complex(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=24 integer(psb_ipk_) :: istack(nparms,maxstack) @@ -1774,7 +1781,7 @@ subroutine psi_zaqsr_up(n,x) end subroutine psi_zaqsr_up subroutine psi_zaqsr_dw(n,x) - use psb_z_sort_mod, psb_protect_name => psi_zaqsr_dw + use psb_sort_mod, psb_protect_name => psi_zaqsr_dw use psb_error_mod implicit none @@ -1784,7 +1791,8 @@ subroutine psi_zaqsr_dw(n,x) real(psb_dpk_) :: piv, xk complex(psb_dpk_) :: xt integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv - integer(psb_ipk_) :: ixt, n1, n2 + integer(psb_ipk_) :: n1, n2 + integer(psb_ipk_) :: ixt integer(psb_ipk_), parameter :: maxstack=64,nparms=3,ithrs=24 integer(psb_ipk_) :: istack(nparms,maxstack) diff --git a/base/tools/Makefile b/base/tools/Makefile index 013c1b57a..029644c41 100644 --- a/base/tools/Makefile +++ b/base/tools/Makefile @@ -1,25 +1,31 @@ include ../../Make.inc -FOBJS = psb_sallc.o psb_sasb.o \ - psb_sfree.o psb_sins.o \ - psb_dallc.o psb_dasb.o \ - psb_dfree.o psb_dins.o \ - psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt.o \ +FOBJS = psb_cdall.o psb_cdals.o psb_cdalv.o psb_cd_inloc.o psb_cdins.o psb_cdprt.o \ psb_cdren.o psb_cdrep.o psb_get_overlap.o psb_cd_lstext.o\ psb_cdcpy.o psb_cd_reinit.o psb_cd_switch_ovl_indxmap.o \ psb_dspalloc.o psb_dspasb.o \ psb_dspfree.o psb_dspins.o psb_dsprn.o \ psb_sspalloc.o psb_sspasb.o \ psb_sspfree.o psb_sspins.o psb_ssprn.o\ - psb_glob_to_loc.o psb_iallc.o psb_iasb.o \ - psb_ifree.o psb_iins.o psb_loc_to_glob.o\ + psb_glob_to_loc.o psb_loc_to_glob.o\ + psb_iallc.o psb_iasb.o psb_ifree.o psb_iins.o \ + psb_lallc.o psb_lasb.o psb_lfree.o psb_lins.o \ + psb_sallc.o psb_sasb.o psb_sfree.o psb_sins.o \ + psb_dallc.o psb_dasb.o psb_dfree.o psb_dins.o \ + psb_callc.o psb_casb.o psb_cfree.o psb_cins.o \ psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \ + psb_mallc_a.o psb_masb_a.o psb_mfree_a.o psb_mins_a.o \ + psb_eallc_a.o psb_easb_a.o psb_efree_a.o psb_eins_a.o \ + psb_sallc_a.o psb_sasb_a.o psb_sfree_a.o psb_sins_a.o \ + psb_dallc_a.o psb_dasb_a.o psb_dfree_a.o psb_dins_a.o \ + psb_callc_a.o psb_casb_a.o psb_cfree_a.o psb_cins_a.o \ + psb_zallc_a.o psb_zasb_a.o psb_zfree_a.o psb_zins_a.o \ psb_zspalloc.o psb_zspasb.o psb_zspfree.o\ psb_zspins.o psb_zsprn.o \ psb_cspalloc.o psb_cspasb.o psb_cspfree.o\ - psb_callc.o psb_casb.o psb_cfree.o psb_cins.o \ psb_cspins.o psb_csprn.o psb_cd_set_bld.o \ psb_s_map.o psb_d_map.o psb_c_map.o psb_z_map.o +# psb_lallc.o psb_lasb.o psb_lfree.o psb_lins.o \ MPFOBJS = psb_icdasb.o psb_ssphalo.o psb_dsphalo.o psb_csphalo.o psb_zsphalo.o \ psb_dcdbldext.o psb_zcdbldext.o psb_scdbldext.o psb_ccdbldext.o diff --git a/base/tools/psb_c_map.f90 b/base/tools/psb_c_map.f90 index eeaefdc0d..796a6c2c0 100644 --- a/base/tools/psb_c_map.f90 +++ b/base/tools/psb_c_map.f90 @@ -401,7 +401,7 @@ function psb_c_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) & type(psb_desc_type), target :: desc_X, desc_Y type(psb_cspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) ! integer(psb_ipk_) :: info character(len=20), parameter :: name='psb_linmap' diff --git a/base/tools/psb_callc.f90 b/base/tools/psb_callc.f90 index 24d83cae1..6464ab3b9 100644 --- a/base/tools/psb_callc.f90 +++ b/base/tools/psb_callc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_calloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_calloc - use psi_mod - implicit none - - !....parameters... - complex(psb_spk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)') - goto 9999 - endif - - x(:,:) = czero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_calloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Function: psb_callocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_callocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_callocv - use psi_mod - implicit none - - !....parameters... - complex(psb_spk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)') - goto 9999 - endif - - x(:) = czero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_callocv - - subroutine psb_calloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_calloc_vect use psi_mod @@ -258,7 +55,7 @@ subroutine psb_calloc_vect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: ictxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -295,7 +92,7 @@ subroutine psb_calloc_vect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -303,8 +100,7 @@ subroutine psb_calloc_vect(x, desc_a,info,n) if (info == 0) call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif call x%zero() @@ -331,7 +127,7 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -378,8 +174,7 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -392,7 +187,7 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -407,8 +202,7 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb) end if if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif @@ -435,7 +229,7 @@ subroutine psb_calloc_multivect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -477,8 +271,7 @@ subroutine psb_calloc_multivect(x, desc_a,info,n) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -491,7 +284,7 @@ subroutine psb_calloc_multivect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -501,8 +294,7 @@ subroutine psb_calloc_multivect(x, desc_a,info,n) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif diff --git a/base/tools/psb_callc_a.f90 b/base/tools/psb_callc_a.f90 new file mode 100644 index 000000000..df3a41b18 --- /dev/null +++ b/base/tools/psb_callc_a.f90 @@ -0,0 +1,246 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_callc.f90 +! +! Function: psb_calloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_calloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_calloc + use psi_mod + implicit none + + !....parameters... + complex(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: err,nr,i,j,n_,err_act + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: exch(3) + character(len=20) :: name + + name='psb_geall' + info = psb_success_ + err = 0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr*n_/),a_err='complex(psb_spk_)') + goto 9999 + endif + + x(:,:) = czero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_calloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Function: psb_callocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_callocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_callocv + use psi_mod + implicit none + + !....parameters... + complex(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: nr,i,err_act + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='complex(psb_spk_)') + goto 9999 + endif + + x(:) = czero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_callocv + diff --git a/base/tools/psb_casb.f90 b/base/tools/psb_casb.f90 index 463ec37d1..5c6b7dc29 100644 --- a/base/tools/psb_casb.f90 +++ b/base/tools/psb_casb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - complex, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_casb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_casb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_cgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_casb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_casb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - complex, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_casbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_casbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - complex(psb_spk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_cgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_casbv - - subroutine psb_casb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_casb_vect implicit none @@ -266,7 +54,7 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -274,7 +62,6 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_cgeasb_v' ictxt = desc_a%get_context() @@ -340,7 +127,7 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me, i, n - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -348,7 +135,6 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_cgeasb_v' ictxt = desc_a%get_context() @@ -423,7 +209,7 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -432,7 +218,6 @@ subroutine psb_casb_multivect(x, desc_a, info, mold, scratch,n) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_cgeasb' ictxt = desc_a%get_context() diff --git a/base/tools/psb_casb_a.f90 b/base/tools/psb_casb_a.f90 new file mode 100644 index 000000000..5d4e4d6a6 --- /dev/null +++ b/base/tools/psb_casb_a.f90 @@ -0,0 +1,259 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_casb.f90 +! +! Subroutine: psb_casb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_casb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_casb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_cgeasb_m' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_casb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_casb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_casbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_casbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_spk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'psb_cgeasb_v' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_casbv diff --git a/base/tools/psb_ccdbldext.F90 b/base/tools/psb_ccdbldext.F90 index 705e82afe..2431a70ec 100644 --- a/base/tools/psb_ccdbldext.F90 +++ b/base/tools/psb_ccdbldext.F90 @@ -84,18 +84,20 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) integer(psb_ipk_) :: i, j, err_act,m,& & lovr, lworks,lworkr, n_row,n_col, n_col_prev, & & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo - integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,& + integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e, & & idx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ - integer(psb_mpik_) :: icomm, ictxt, me, np, minfo + integer(psb_lpk_) :: gidx, lnz + integer(psb_mpk_) :: icomm, ictxt, me, np, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) - integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),works(:),workr(:),& + integer(psb_lpk_), allocatable :: works(:),workr(:) + integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),& & t_halo_in(:), t_halo_out(:),temp(:),maskr(:) - integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) + integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -262,13 +264,13 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - orig_ovr(cntov_o)=proc - orig_ovr(cntov_o+1)=1 - orig_ovr(cntov_o+2)=idx - orig_ovr(cntov_o+3)=-1 + orig_ovr(cntov_o) = proc + orig_ovr(cntov_o+1) = 1 + orig_ovr(cntov_o+2) = idx + orig_ovr(cntov_o+3) = -1 cntov_o=cntov_o+3 end Do - counter=counter+n_elem_recv+n_elem_send+3 + counter = counter+n_elem_recv+n_elem_send+3 end Do @@ -319,16 +321,16 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) n_col_prev = desc_ov%get_local_cols() Do While (halo(counter) /= -1) - tot_elem=0 - proc=halo(counter+psb_proc_id_) - n_elem_recv=halo(counter+psb_n_elem_recv_) - n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) + tot_elem = 0 + proc = halo(counter+psb_proc_id_) + n_elem_recv = halo(counter+psb_n_elem_recv_) + n_elem_send = halo(counter+n_elem_recv+psb_n_elem_send_) If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then info = -1 call psb_errpush(info,name) goto 9999 end If - tot_recv=tot_recv+n_elem_recv + tot_recv = tot_recv+n_elem_recv if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ': tot_recv:',proc,n_elem_recv,tot_recv @@ -407,6 +409,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! If (i_ovr <= (novr)) Then call a%csget(idx,idx,n_elem,irow,icol,info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='csget') @@ -431,8 +434,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) if (i_ovr <= novr) then if (tot_elem > 1) then - call psb_msort_unique(works(idxs+1:idxs+tot_elem),i) - tot_elem=i + call psb_msort_unique(works(idxs+1:idxs+tot_elem),lnz) + tot_elem = lnz endif sdsz(proc+1) = tot_elem @@ -451,8 +454,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) ! accumulated RECV requests, we have an all-to-all to build ! matchings SENDs. ! - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, & - & psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,rvsz,1, & + & psb_mpi_mpk_,icomm,minfo) if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') @@ -487,8 +490,8 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) lworkr = max(iszr,1) end if - call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_ipk_integer,& - & workr,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_lpk_,& + & workr,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') @@ -514,12 +517,13 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) j = 0 do i=1,iszr if (maskr(i) < 0) then - j=j+1 + j = j+1 works(j) = workr(i) end if end do ! Eliminate duplicates from request - call psb_msort_unique(works(1:j),iszs) + call psb_msort_unique(works(1:j),lnz) + iszs = lnz ! ! fnd_owner on desc_a because we want the procs who @@ -536,9 +540,9 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) & ': Done fnd_owner', desc_ov%indxmap%get_state() do i=1,iszs - idx = works(i) - n_col = desc_ov%get_local_cols() - call desc_ov%indxmap%g2l_ins(idx,lidx,info) + gidx = works(i) + n_col = desc_ov%get_local_cols() + call desc_ov%indxmap%g2l_ins(gidx,lidx,info) if (desc_ov%get_local_cols() > n_col ) then ! ! This is a new index. Assigning a local index as @@ -640,7 +644,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 end if orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) - cntov_o = cntov_o+counter_o-1 + cntov_o = cntov_o+counter_o-1 orig_ovr(cntov_o:) = -1 call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) deallocate(tmp_ovr_idx,stat=info) diff --git a/base/tools/psb_cd_inloc.f90 b/base/tools/psb_cd_inloc.f90 index 6ea184d19..6f9fb2a3d 100644 --- a/base/tools/psb_cd_inloc.f90 +++ b/base/tools/psb_cd_inloc.f90 @@ -49,7 +49,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) use psb_hash_map_mod implicit None !....Parameters... - integer(psb_ipk_), intent(in) :: ictxt, v(:) + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_lpk_), intent(in) :: v(:) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(out) :: desc logical, intent(in), optional :: globalcheck @@ -57,14 +58,18 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) !locals integer(psb_ipk_) :: i,j,np,me,loc_row,err,& - & loc_col,nprocs,n, k,glx,nlu,& - & flag_, err_act,m, novrl, norphan,& - & npr_ov, itmpov, i_pnt, nrt - integer(psb_ipk_) :: int_err(5),exch(3) - integer(psb_ipk_), allocatable :: temp_ovrlap(:), tmpgidx(:,:), vl(:),& - & nov(:), ov_idx(:,:), ix(:) + & loc_col,nprocs,k,glx,nlu,& + & flag_, err_act, novrl, norphan,& + & npr_ov, itmpov, i_pnt + integer(psb_lpk_) :: m, n, nrt, il + integer(psb_lpk_) :: l_err(5),exch(3) + integer(psb_ipk_), allocatable :: tmpgidx(:,:), & + & nov(:), ov_idx(:,:), temp_ovrlap(:) + integer(psb_lpk_), allocatable :: vl(:), ix(:), l_temp_ovrlap(:) integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpik_) :: iictxt + integer(psb_mpk_) :: iictxt + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + logical :: do_timings=.false. logical :: check_, islarge character(len=20) :: name @@ -80,7 +85,10 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': start',np iictxt = ictxt - + if (do_timings) then + call psb_barrier(ictxt) + t0 = psb_wtime() + end if loc_row = size(v) m = maxval(v) nrt = loc_row @@ -98,16 +106,16 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) !... check m and n parameters.... if (m < 1) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m + l_err(1) = 1 + l_err(2) = m else if (n < 1) then info = psb_err_iarg_neg_ - int_err(1) = 2 - int_err(2) = n + l_err(1) = 2 + l_err(2) = n endif if (info /= psb_success_) then - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,l_err=l_err) goto 9999 end if if (me == psb_root_) then @@ -119,18 +127,17 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) call psb_bcast(ictxt,exch(1:3),root=psb_root_) if (exch(1) /= m) then err=550 - int_err(1)=1 - call psb_errpush(err,name,int_err) + l_err(1)=1 + call psb_errpush(err,name,l_err=l_err) goto 9999 else if (exch(2) /= n) then err=550 - int_err(1)=2 - call psb_errpush(err,name,int_err) + l_err(1)=2 + call psb_errpush(err,name,l_err=l_err) goto 9999 endif call psb_cd_set_large_threshold(exch(3)) endif - if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': doing global checks' @@ -139,7 +146,7 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) allocate(vl(loc_row),ix(loc_row),stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,l_err=l_err) goto 9999 end if @@ -151,11 +158,11 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) ! Checks 2 and 3 are controlled by globalcheck ! - if (check_.or.(.not.islarge)) then + if (check_.or.(.not.islarge)) then allocate(tmpgidx(m,2),stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,l_err=l_err) goto 9999 end if tmpgidx = 0 @@ -163,10 +170,10 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) do i=1,loc_row if ((v(i)<1).or.(v(i)>m)) then info = psb_err_entry_out_of_bounds_ - int_err(1) = i - int_err(2) = v(i) - int_err(3) = loc_row - int_err(4) = m + l_err(1) = i + l_err(2) = v(i) + l_err(3) = loc_row + l_err(4) = m else tmpgidx(v(i),1) = me+flag_ tmpgidx(v(i),2) = 1 @@ -180,20 +187,21 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) novrl = 0 npr_ov = 0 norphan = 0 - do i=1, m - if (tmpgidx(i,2) < 1) then + do il=1, m + if (tmpgidx(il,2) < 1) then norphan = norphan + 1 - else if (tmpgidx(i,2) > 1) then + else if (tmpgidx(il,2) > 1) then novrl = novrl + 1 - npr_ov = npr_ov + tmpgidx(i,2) + npr_ov = npr_ov + tmpgidx(il,2) end if end do if (norphan > 0) then - int_err(1) = norphan - int_err(2) = m + l_err(1) = norphan + l_err(2) = m info = psb_err_inconsistent_index_lists_ end if end if + else novrl = 0 norphan = 0 @@ -201,10 +209,10 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) do i=1,loc_row if ((v(i)<1).or.(v(i)>m)) then info = psb_err_entry_out_of_bounds_ - int_err(1) = i - int_err(2) = v(i) - int_err(3) = loc_row - int_err(4) = m + l_err(1) = i + l_err(2) = v(i) + l_err(3) = loc_row + l_err(4) = m exit endif vl(i) = v(i) @@ -215,9 +223,13 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) write(psb_err_unit,*) trim(name),' : in the global sizes!',m,nrt end if end if + if (do_timings) then + call psb_barrier(ictxt) + t1 = psb_wtime() + end if if (info /= psb_success_) then - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,l_err=l_err) goto 9999 end if @@ -248,9 +260,16 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) call psb_msort(ix(1:nlu),vl(1:nlu),flag=psb_sort_keep_idx_) call psb_nullify_desc(desc) + if (do_timings) then + call psb_barrier(ictxt) + t2 = psb_wtime() + end if ! - ! Figure out overlap in the input + ! Figure out overlap in the input. + ! Note: the code above guarantees that if mpgidx was not allocated, + ! then novrl = 0, hence all accesses to tmpgidx + ! are safe. ! if (novrl > 0) then if (debug_level >= psb_debug_ext_) & @@ -259,8 +278,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) allocate(nov(0:np),ov_idx(npr_ov,2),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=np + 2*npr_ov - call psb_errpush(info,name,i_err=int_err,a_err='integer') + l_err(1)=np + 2*npr_ov + call psb_errpush(info,name,l_err=l_err,a_err='integer') goto 9999 endif nov=0 @@ -298,20 +317,19 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) end if ! allocate work vector - allocate(temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& + allocate(l_temp_ovrlap(max(1,2*loc_row)),desc%lprm(1),& & stat=info) if (info == psb_success_) then desc%lprm(1) = 0 end if if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=2*m+psb_mdata_size_ - call psb_errpush(info,name,i_err=int_err,a_err='integer') + l_err(1)=2*m+psb_mdata_size_ + call psb_errpush(info,name,l_err=l_err,a_err='integer') goto 9999 endif - temp_ovrlap(:) = -1 - + l_temp_ovrlap(:) = -1 if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info @@ -320,8 +338,8 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) itmpov = 0 if (check_) then do k=1, loc_row - i = v(k) - nprocs = tmpgidx(i,2) + il = v(k) + nprocs = tmpgidx(il,2) if (nprocs > 1) then do if (j > size(ov_idx,dim=1)) then @@ -332,22 +350,27 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) if (ov_idx(j,1) == i) exit j = j + 1 end do - call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-ione) + call psb_ensure_size((itmpov+3+nprocs),l_temp_ovrlap,info,pad=-1_psb_lpk_) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if itmpov = itmpov + 1 - temp_ovrlap(itmpov) = i + l_temp_ovrlap(itmpov) = il itmpov = itmpov + 1 - temp_ovrlap(itmpov) = nprocs - temp_ovrlap(itmpov+1:itmpov+nprocs) = ov_idx(j:j+nprocs-1,2) + l_temp_ovrlap(itmpov) = nprocs + l_temp_ovrlap(itmpov+1:itmpov+nprocs) = ov_idx(j:j+nprocs-1,2) itmpov = itmpov + nprocs end if end do end if + if (do_timings) then + call psb_barrier(ictxt) + t3 = psb_wtime() + end if + if (np == 1) then allocate(psb_repl_map :: desc%indxmap, stat=info) else @@ -365,6 +388,10 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) call aa%init(iictxt,vl(1:nlu),info) end select + if (do_timings) then + call psb_barrier(ictxt) + t4 = psb_wtime() + end if ! ! Now that we have initialized indxmap we can convert the @@ -372,16 +399,22 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) ! block integer(psb_ipk_) :: i,nprocs - i = 1 - do while (temp_ovrlap(i) /= -1) - call desc%indxmap%g2lip(temp_ovrlap(i),info) - i = i + 1 - nprocs = temp_ovrlap(i) - i = i + 1 - i = i + nprocs - enddo + allocate(temp_ovrlap(size(l_temp_ovrlap)),stat=info) + if (info == psb_success_) then + temp_ovrlap = -1 + i = 1 + do while (l_temp_ovrlap(i) /= -1) + call desc%indxmap%g2l(l_temp_ovrlap(i),temp_ovrlap(i),info) + i = i + 1 + temp_ovrlap(i) = l_temp_ovrlap(i) + nprocs = temp_ovrlap(i) + temp_ovrlap(i+1:i+nprocs) = l_temp_ovrlap(i+1:i+nprocs) + i = i + 1 + i = i + nprocs + enddo + end if end block - call psi_bld_tmpovrl(temp_ovrlap,desc,info) + if (info == psb_success_) call psi_bld_tmpovrl(temp_ovrlap,desc,info) if (info == psb_success_) deallocate(temp_ovrlap,vl,ix,stat=info) if ((info == psb_success_).and.(allocated(tmpgidx)))& @@ -394,6 +427,30 @@ subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) goto 9999 endif + if (do_timings) then + call psb_barrier(ictxt) + t5 = psb_wtime() + + t5 = t5 - t4 + t4 = t4 - t3 + t3 = t3 - t2 + t2 = t2 - t1 + t1 = t1 - t0 + call psb_amx(ictxt,t1) + call psb_amx(ictxt,t2) + call psb_amx(ictxt,t3) + call psb_amx(ictxt,t4) + call psb_amx(ictxt,t5) + if (me==0) then + write(0,*) 'CD_INLOC Timings: ' + write(0,*) ' Phase 1 : ', t1 + write(0,*) ' Phase 2 : ', t2 + write(0,*) ' Phase 3 : ', t3 + write(0,*) ' Phase 4 : ', t4 + write(0,*) ' Phase 5 : ', t5 + end if + end if + call psb_erractionrestore(err_act) return diff --git a/base/tools/psb_cd_lstext.f90 b/base/tools/psb_cd_lstext.f90 index 4405aac00..d8f60f256 100644 --- a/base/tools/psb_cd_lstext.f90 +++ b/base/tools/psb_cd_lstext.f90 @@ -38,7 +38,7 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype) ! .. Array Arguments .. Type(psb_desc_type), Intent(inout), target :: desc_a - integer(psb_ipk_), intent(in) :: in_list(:) + integer(psb_lpk_), intent(in) :: in_list(:) Type(psb_desc_type), Intent(out) :: desc_ov integer(psb_ipk_), intent(out) :: info logical, intent(in), optional, target :: mask(:) diff --git a/base/tools/psb_cd_switch_ovl_indxmap.f90 b/base/tools/psb_cd_switch_ovl_indxmap.f90 index 034c35d52..ea8aabcfc 100644 --- a/base/tools/psb_cd_switch_ovl_indxmap.f90 +++ b/base/tools/psb_cd_switch_ovl_indxmap.f90 @@ -45,12 +45,13 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info) integer(psb_ipk_), intent(out) :: info ! .. Local Scalars .. - integer(psb_ipk_) :: i, j, np, me, mglob, ictxt, n_row, n_col + integer(psb_ipk_) :: i, j, np, me, ictxt, n_row, n_col + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: err_act - integer(psb_ipk_), allocatable :: vl(:) + integer(psb_lpk_), allocatable :: vl(:) integer(psb_ipk_) :: debug_level, debug_unit, ierr(5) - integer(psb_mpik_) :: iictxt + integer(psb_mpk_) :: iictxt character(len=20) :: name, ch_err name='cd_switch_ovl_indxmap' diff --git a/base/tools/psb_cdall.f90 b/base/tools/psb_cdall.f90 index 46aa9d443..d79f1f210 100644 --- a/base/tools/psb_cdall.f90 +++ b/base/tools/psb_cdall.f90 @@ -8,8 +8,9 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche use psi_mod implicit None procedure(psb_parts) :: parts - integer(psb_ipk_), intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl,lidx(:) - integer(psb_ipk_), intent(in) :: flag + integer(psb_lpk_), intent(in) :: mg,ng, vl(:) + integer(psb_ipk_), intent(in) :: ictxt, vg(:), lidx(:),nl + integer(psb_ipk_), intent(in) :: flag logical, intent(in) :: repl, globalcheck integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(out) :: desc @@ -20,9 +21,10 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche subroutine psb_cdals(m, n, parts, ictxt, desc, info) use psb_desc_mod procedure(psb_parts) :: parts - integer(psb_ipk_), intent(in) :: m,n,ictxt - Type(psb_desc_type), intent(out) :: desc - integer(psb_ipk_), intent(out) :: info + integer(psb_lpk_), intent(in) :: m,n + integer(psb_ipk_), intent(in) :: ictxt + Type(psb_desc_type), intent(out) :: desc + integer(psb_ipk_), intent(out) :: info end subroutine psb_cdals subroutine psb_cdalv(v, ictxt, desc, info, flag) use psb_desc_mod @@ -34,7 +36,8 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche subroutine psb_cd_inloc(v, ictxt, desc, info, globalcheck,idx) use psb_desc_mod implicit None - integer(psb_ipk_), intent(in) :: ictxt, v(:) + integer(psb_ipk_), intent(in) :: ictxt + integer(psb_lpk_), intent(in) :: v(:) integer(psb_ipk_), intent(out) :: info type(psb_desc_type), intent(out) :: desc logical, intent(in), optional :: globalcheck @@ -42,15 +45,17 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche end subroutine psb_cd_inloc subroutine psb_cdrep(m, ictxt, desc,info) use psb_desc_mod - integer(psb_ipk_), intent(in) :: m,ictxt + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: ictxt Type(psb_desc_type), intent(out) :: desc - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_cdrep end interface character(len=20) :: name - integer(psb_ipk_) :: err_act, n_, flag_, i, me, np, nlp, nnv, lr + integer(psb_ipk_) :: err_act, flag_, i, me, np, nlp, nnv, lr + integer(psb_lpk_) :: n_ integer(psb_ipk_), allocatable :: itmpsz(:) - integer(psb_mpik_) :: iictxt + integer(psb_mpk_) :: iictxt @@ -138,8 +143,9 @@ subroutine psb_cdall(ictxt, desc, info,mg,ng,parts,vg,vl,flag,nl,repl, globalche end if if (info == psb_success_) then select type(aa => desc%indxmap) - type is (psb_repl_map) - call aa%repl_map_init(iictxt,nl,info) + type is (psb_repl_map) + n_ = nl + call aa%repl_map_init(iictxt,n_,info) type is (psb_gen_block_map) call aa%gen_block_map_init(iictxt,nl,info) class default diff --git a/base/tools/psb_cdals.f90 b/base/tools/psb_cdals.f90 index e141a4277..dc8a28738 100644 --- a/base/tools/psb_cdals.f90 +++ b/base/tools/psb_cdals.f90 @@ -52,19 +52,22 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) implicit None procedure(psb_parts) :: parts !....Parameters... - integer(psb_ipk_), intent(in) :: M,N,ictxt + integer(psb_lpk_), intent(in) :: M,N + integer(psb_ipk_), intent(in) :: ictxt Type(psb_desc_type), intent(out) :: desc integer(psb_ipk_), intent(out) :: info !locals integer(psb_ipk_) :: counter,i,j,loc_row,err,loc_col,& - & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, nlx - integer(psb_ipk_) :: int_err(5),exch(3) - integer(psb_ipk_), allocatable :: temp_ovrlap(:), loc_idx(:) + & l_ov_ix,l_ov_el,idx, err_act, itmpov, k, glx, nlx + integer(psb_lpk_) :: iglob + integer(psb_ipk_) :: exch(3) + integer(psb_ipk_), allocatable :: temp_ovrlap(:) + integer(psb_lpk_), allocatable :: l_temp_ovrlap(:), loc_idx(:) integer(psb_ipk_), allocatable :: prc_v(:) integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: me, np, nprocs - integer(psb_mpik_) :: iictxt + integer(psb_mpk_) :: iictxt character(len=20) :: name if(psb_get_errstatus() /= 0) return @@ -84,14 +87,12 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (m < 1) then info = psb_err_iarg_neg_ err=info - int_err(1) = 1; int_err(2) = m; - call psb_errpush(err,name,int_err) + call psb_errpush(err,name,l_err=(/lone,m/)) goto 9999 else if (n < 1) then info = psb_err_iarg_neg_ err=info - int_err(1) = 2 ; int_err(2) = n; - call psb_errpush(err,name,int_err) + call psb_errpush(err,name,l_err=(/lone*2,n/)) goto 9999 endif @@ -105,13 +106,11 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) call psb_bcast(ictxt,exch(1:3),root=psb_root_) if (exch(1) /= m) then err=550 - int_err(1)=1 - call psb_errpush(err,name,int_err) + call psb_errpush(err,name,m_err=(/1/)) goto 9999 else if (exch(2) /= n) then err=550 - int_err(1)=2 - call psb_errpush(err,name,int_err) + call psb_errpush(err,name,m_err=(/2/)) goto 9999 endif call psb_cd_set_large_threshold(exch(3)) @@ -122,13 +121,12 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) ! count local rows number loc_row = max(1,(m+np-1)/np) ! allocate work vector - allocate(temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) + allocate(l_temp_ovrlap(max(1,2*loc_row)), prc_v(np),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ err=info - int_err(1)=2*m+psb_mdata_size_+np - call psb_errpush(err,name,int_err,a_err='integer') + call psb_errpush(err,name,a_err='integer',l_err=(/2*m+psb_mdata_size_+np/)) goto 9999 endif @@ -136,7 +134,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) & write(debug_unit,*) me,' ',trim(name),': starting main loop' ,info counter = 0 itmpov = 0 - temp_ovrlap(:) = -1 + l_temp_ovrlap(:) = -1 ! ! We have to decide whether we have a "large" index space. ! @@ -165,8 +163,7 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=loc_col - call psb_errpush(info,name,i_err=int_err,a_err='integer') + call psb_errpush(info,name,i_err=(/loc_col/),a_err='integer') goto 9999 end if @@ -174,35 +171,22 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) desc%lprm(1) = 0 k = 0 - do i=1,m + do iglob=1,m if (info == psb_success_) then - call parts(i,m,np,prc_v,nprocs) + call parts(iglob,m,np,prc_v,nprocs) if (nprocs > np) then info=psb_err_partfunc_toomuchprocs_ - int_err(1)=3 - int_err(2)=np - int_err(3)=nprocs - int_err(4)=i - err=info - call psb_errpush(err,name,int_err) + call psb_errpush(info,name,l_err=(/3_psb_lpk_,np*lone,nprocs*lone,iglob/)) goto 9999 else if (nprocs <= 0) then info=psb_err_partfunc_toofewprocs_ - int_err(1)=3 - int_err(2)=nprocs - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) + call psb_errpush(info,name,l_err=(/3_psb_lpk_,nprocs*lone,iglob/)) goto 9999 else do j=1,nprocs if ((prc_v(j) > np-1).or.(prc_v(j) < 0)) then info=psb_err_partfunc_wrong_pid_ - int_err(1)=3 - int_err(2)=prc_v(j) - int_err(3)=i - err=info - call psb_errpush(err,name,int_err) + call psb_errpush(info,name,l_err=(/3_psb_lpk_,prc_v(j)*lone,iglob/)) goto 9999 end if end do @@ -218,26 +202,26 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (prc_v(j) == me) then ! this point belongs to me k = k + 1 - call psb_ensure_size((k+1),loc_idx,info,pad=-ione) + call psb_ensure_size((k+1),loc_idx,info,pad=-1_psb_lpk_) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - loc_idx(k) = i + loc_idx(k) = iglob if (nprocs > 1) then - call psb_ensure_size((itmpov+3+nprocs),temp_ovrlap,info,pad=-ione) + call psb_ensure_size((itmpov+3+nprocs),l_temp_ovrlap,info,pad=-1_psb_lpk_) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if itmpov = itmpov + 1 - temp_ovrlap(itmpov) = i + l_temp_ovrlap(itmpov) = iglob itmpov = itmpov + 1 - temp_ovrlap(itmpov) = nprocs - temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) + l_temp_ovrlap(itmpov) = nprocs + l_temp_ovrlap(itmpov+1:itmpov+nprocs) = prc_v(1:nprocs) itmpov = itmpov + nprocs endif end if @@ -266,23 +250,28 @@ subroutine psb_cdals(m, n, parts, ictxt, desc, info) if (debug_level >= psb_debug_ext_) & & write(debug_unit,*) me,' ',trim(name),': error check:' ,err - ! ! Now that we have initialized indxmap we can convert the ! indices to local numbering. ! block integer(psb_ipk_) :: i,nprocs - i = 1 - do while (temp_ovrlap(i) /= -1) - call desc%indxmap%g2lip(temp_ovrlap(i),info) - i = i + 1 - nprocs = temp_ovrlap(i) - i = i + 1 - i = i + nprocs - enddo + allocate(temp_ovrlap(size(l_temp_ovrlap)),stat=info) + if (info == psb_success_) then + temp_ovrlap = -1 + i = 1 + do while (l_temp_ovrlap(i) /= -1) + call desc%indxmap%g2l(l_temp_ovrlap(i),temp_ovrlap(i),info) + i = i + 1 + temp_ovrlap(i) = l_temp_ovrlap(i) + nprocs = temp_ovrlap(i) + temp_ovrlap(i+1:i+nprocs) = l_temp_ovrlap(i+1:i+nprocs) + i = i + 1 + i = i + nprocs + enddo + end if end block - call psi_bld_tmpovrl(temp_ovrlap,desc,info) + if (info == psb_success_) call psi_bld_tmpovrl(temp_ovrlap,desc,info) if (info == psb_success_) deallocate(prc_v,temp_ovrlap,stat=info) if (info /= psb_no_err_) then diff --git a/base/tools/psb_cdalv.f90 b/base/tools/psb_cdalv.f90 index c238edcf8..1e433eaae 100644 --- a/base/tools/psb_cdalv.f90 +++ b/base/tools/psb_cdalv.f90 @@ -57,13 +57,14 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) type(psb_desc_type), intent(out) :: desc !locals - integer(psb_ipk_) :: counter,i,j,np,me,loc_row,err,& - & loc_col,nprocs,m,n,itmpov, k,glx,& + integer(psb_ipk_) :: counter,j,np,me,loc_row,err,& + & loc_col,nprocs,itmpov, k,glx,& & l_ov_ix,l_ov_el,idx, flag_, err_act - integer(psb_ipk_) :: int_err(5),exch(3) + integer(psb_lpk_) :: m,n,i,exch(3) + integer(psb_lpk_) :: l_err(5) integer(psb_ipk_), allocatable :: temp_ovrlap(:) integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpik_) :: iictxt + integer(psb_mpk_) :: iictxt character(len=20) :: name if(psb_get_errstatus() /= 0) return @@ -82,20 +83,20 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) !... check m and n parameters.... if (m < 1) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m + l_err(1) = 1 + l_err(2) = m else if (n < 1) then info = psb_err_iarg_neg_ - int_err(1) = 2 - int_err(2) = n + l_err(1) = 2 + l_err(2) = n else if (size(v)1)) then info = 6 - err=info call psb_errpush(info,name) goto 9999 end if @@ -141,8 +141,8 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) allocate(temp_ovrlap(2),stat=info) if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=2*m+psb_mdata_size_ - call psb_errpush(info,name,i_err=int_err,a_err='integer') + l_err(1)=2*m+psb_mdata_size_ + call psb_errpush(info,name,l_err=l_err,a_err='integer') goto 9999 endif @@ -156,9 +156,9 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) if (((v(i)-flag_) > np-1).or.((v(i)-flag_) < 0)) then info=psb_err_partfunc_wrong_pid_ - int_err(1)=3 - int_err(2)=v(i) - flag_ - int_err(3)=i + l_err(1)=3 + l_err(2)=v(i) - flag_ + l_err(3)=i exit end if @@ -167,6 +167,11 @@ subroutine psb_cdalv(v, ictxt, desc, info, flag) counter=counter+1 end if enddo + if (info /= psb_success_) then + call psb_errpush(info,name,l_err=l_err) + goto 9999 + endif + loc_row=counter ! diff --git a/base/tools/psb_cdins.f90 b/base/tools/psb_cdins.f90 index a8b0441c0..3ac5ee42b 100644 --- a/base/tools/psb_cdins.f90 +++ b/base/tools/psb_cdins.f90 @@ -52,7 +52,8 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) !....PARAMETERS... Type(psb_desc_type), intent(inout) :: desc_a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(out) :: ila(:), jla(:) !LOCALS..... @@ -133,8 +134,7 @@ subroutine psb_cdinsrc(nz,ia,ja,desc_a,info,ila,jla) end if call desc_a%indxmap%g2l(ia(1:nz),ila_(1:nz),info,owned=.true.) if (info == psb_success_) then - jla_(1:nz) = ja(1:nz) - call desc_a%indxmap%g2lip_ins(jla_(1:nz),info,mask=(ila_(1:nz)>0)) + call desc_a%indxmap%g2l_ins(ja(1:nz),jla_(1:nz),info,mask=(ila_(1:nz)>0)) end if deallocate(ila_,jla_,stat=info) end if @@ -170,7 +170,8 @@ subroutine psb_cdinsc(nz,ja,desc,info,jla,mask,lidx) !....PARAMETERS... Type(psb_desc_type), intent(inout) :: desc - integer(psb_ipk_), intent(in) :: nz,ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ja(:) integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(out) :: jla(:) logical, optional, target, intent(in) :: mask(:) diff --git a/base/tools/psb_cdprt.f90 b/base/tools/psb_cdprt.f90 index 8ada03cb9..10222f37f 100644 --- a/base/tools/psb_cdprt.f90 +++ b/base/tools/psb_cdprt.f90 @@ -133,7 +133,7 @@ contains integer(psb_ipk_) :: ip, nerv, nesd, totxch,idxr,idxs integer(psb_ipk_) :: ictxt, me, np, data_, info, verb_ - integer(psb_ipk_), allocatable :: gidx(:) + integer(psb_lpk_), allocatable :: gidx(:) class(psb_i_base_vect_type), pointer :: vpnt ictxt = desc_p%get_ctxt() diff --git a/base/tools/psb_cdren.f90 b/base/tools/psb_cdren.f90 index 3df0750f5..95568a8eb 100644 --- a/base/tools/psb_cdren.f90 +++ b/base/tools/psb_cdren.f90 @@ -58,7 +58,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info) !....locals.... integer(psb_ipk_) :: i,j,np,me, n_col, kh, nh integer(psb_ipk_) :: dectype - integer(psb_ipk_) :: ictxt,n_row, int_err(5), err_act + integer(psb_ipk_) :: ictxt,n_row, err_act integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -84,16 +84,14 @@ subroutine psb_cdren(trans,iperm,desc_a,info) if (.not.psb_is_asb_desc(desc_a)) then info = psb_err_invalid_cd_state_ - int_err(1) = dectype - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/dectype/)) goto 9999 endif if (iperm(1) /= 0) then if (.not.psb_isaperm(n_row,iperm)) then info = 610 - int_err(1) = iperm(1) - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/iperm(1)/)) goto 9999 endif endif diff --git a/base/tools/psb_cdrep.f90 b/base/tools/psb_cdrep.f90 index b5e76c487..61f0ac2ad 100644 --- a/base/tools/psb_cdrep.f90 +++ b/base/tools/psb_cdrep.f90 @@ -107,15 +107,18 @@ subroutine psb_cdrep(m, ictxt, desc, info) use psb_repl_map_mod implicit None !....Parameters... - integer(psb_ipk_), intent(in) :: m,ictxt + integer(psb_lpk_), intent(in) :: m + integer(psb_ipk_), intent(in) :: ictxt integer(psb_ipk_), intent(out) :: info Type(psb_desc_type), intent(out) :: desc !locals - integer(psb_ipk_) :: i,np,me,err,n,err_act - integer(psb_ipk_) :: int_err(5),exch(2), thalo(1), tovr(1), text(1) + integer(psb_ipk_) :: i,np,me,err,err_act + integer(psb_lpk_) :: n + integer(psb_lpk_) :: l_err(5),exch(2) + integer(psb_ipk_) :: thalo(1), tovr(1), text(1) integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_mpik_) :: iictxt + integer(psb_mpk_) :: iictxt character(len=20) :: name if(psb_get_errstatus() /= 0) return @@ -133,16 +136,16 @@ subroutine psb_cdrep(m, ictxt, desc, info) !... check m and n parameters.... if (m < 1) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m + l_err(1) = 1 + l_err(2) = m else if (n < 1) then info = psb_err_iarg_neg_ - int_err(1) = 2 - int_err(2) = n + l_err(1) = 2 + l_err(2) = n endif if (info /= psb_success_) then - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,l_err=l_err) goto 9999 end if @@ -157,15 +160,15 @@ subroutine psb_cdrep(m, ictxt, desc, info) call psb_bcast(ictxt,exch(1:2),root=psb_root_) if (exch(1) /= m) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 + l_err(1)=1 else if (exch(2) /= n) then info=psb_err_parm_differs_among_procs_ - int_err(1)=2 + l_err(1)=2 endif endif if (info /= psb_success_) then - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,l_err=l_err) goto 9999 end if @@ -175,25 +178,6 @@ subroutine psb_cdrep(m, ictxt, desc, info) !count local rows number ! allocate work vector -!!$ allocate(desc%matrix_data(psb_mdata_size_),& -!!$ & desc%ovrlap_elem(0,3),stat=info) -!!$ if (info /= psb_success_) then -!!$ info=psb_err_alloc_request_ -!!$ int_err(1)=2*m+psb_mdata_size_+1 -!!$ call psb_errpush(info,name,i_err=int_err,a_err='integer') -!!$ goto 9999 -!!$ endif -!!$ ! If the index space is replicated there's no point in not having -!!$ ! the full map on the current process. -!!$ -!!$ desc%matrix_data(psb_m_) = m -!!$ desc%matrix_data(psb_n_) = n -!!$ desc%matrix_data(psb_n_row_) = m -!!$ desc%matrix_data(psb_n_col_) = n -!!$ desc%matrix_data(psb_ctxt_) = ictxt -!!$ call psb_get_mpicomm(ictxt,desc%matrix_data(psb_mpi_c_)) -!!$ desc%matrix_data(psb_dec_type_) = psb_desc_bld_ - allocate(psb_repl_map :: desc%indxmap, stat=info) select type(aa => desc%indxmap) diff --git a/base/tools/psb_cfree.f90 b/base/tools/psb_cfree.f90 index f35f13f42..2d38887a3 100644 --- a/base/tools/psb_cfree.f90 +++ b/base/tools/psb_cfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - complex, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_cfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_cfree - implicit none - - !....parameters... - complex(psb_spk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_cfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_cfree - - - -! Subroutine: psb_cfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - complex, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_cfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_cfreev - implicit none - !....parameters... - complex(psb_spk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_cfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_cfreev - subroutine psb_cfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_cfree_vect implicit none diff --git a/base/tools/psb_cfree_a.f90 b/base/tools/psb_cfree_a.f90 new file mode 100644 index 000000000..38621be44 --- /dev/null +++ b/base/tools/psb_cfree_a.f90 @@ -0,0 +1,164 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_cfree.f90 +! +! Subroutine: psb_cfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_cfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_cfree + implicit none + + !....parameters... + complex(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_cfree' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cfree + + + +! Subroutine: psb_cfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_cfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_cfreev + implicit none + !....parameters... + complex(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_cfreev' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cfreev diff --git a/base/tools/psb_cins.f90 b/base/tools/psb_cins.f90 index 9bdb70bc9..a069c33b9 100644 --- a/base/tools/psb_cins.f90 +++ b/base/tools/psb_cins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_cinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_spk_), intent(in) :: val(:) - complex(psb_spk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_cinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_cinsvi - - subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_cins_vect use psi_mod @@ -189,7 +56,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_spk_), intent(in) :: val(:) type(psb_c_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -198,9 +65,9 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -228,15 +95,11 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -303,7 +166,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_c_vect_type), intent(inout) :: val type(psb_c_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -312,9 +175,9 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) complex(psb_spk_), allocatable :: lval(:) logical :: local_ @@ -343,15 +206,11 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -379,15 +238,14 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local) local_ = .false. endif + if (irw%is_dev()) call irw%sync() if (local_) then - call x%ins(m,irw,val,dupl_,info) + irl(1:m) = irw%v%v(1:m) else - irl = irw%get_vect() - lval = val%get_vect() - call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.) - call x%ins(m,irl,lval,dupl_,info) - + call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if + + call x%ins(m,irl,lval,dupl_,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -413,7 +271,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_spk_), intent(in) :: val(:,:) type(psb_c_vect_type), intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a @@ -422,9 +280,9 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5), n - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols, n + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -457,15 +315,11 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x(1)%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -523,197 +377,6 @@ end subroutine psb_cins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_cinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - complex The source dense submatrix. -! x(:,:) - complex The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_cinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_spk_), intent(in) :: val(:,:) - complex(psb_spk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_cinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_cinsi - - - subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_cins_multivect use psi_mod @@ -725,7 +388,7 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_spk_), intent(in) :: val(:,:) type(psb_c_multivect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -734,9 +397,9 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -764,15 +427,11 @@ subroutine psb_cins_multivect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif diff --git a/base/tools/psb_cins_a.f90 b/base/tools/psb_cins_a.f90 new file mode 100644 index 000000000..6e67a0e65 --- /dev/null +++ b/base/tools/psb_cins_a.f90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psb_cinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - complex The source dense submatrix. +! x(:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_cinsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:) + complex(psb_spk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_cinsvi' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cinsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_cinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - complex The source dense submatrix. +! x(:,:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_cinsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + complex(psb_spk_), intent(in) :: val(:,:) + complex(psb_spk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_cinsi' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_cinsi + diff --git a/base/tools/psb_cspalloc.f90 b/base/tools/psb_cspalloc.f90 index f954cc42c..b67aeede5 100644 --- a/base/tools/psb_cspalloc.f90 +++ b/base/tools/psb_cspalloc.f90 @@ -52,16 +52,17 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) integer(psb_ipk_), optional, intent(in) :: nnz !locals - integer(psb_ipk_) :: ictxt, dectype - integer(psb_ipk_) :: np,me,loc_row,loc_col,& - & length_ia1,length_ia2, err_act,m,n - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ictxt, np, me, err_act + integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype + integer(psb_lpk_) :: m, n integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if name = 'psb_cspall' debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -87,26 +88,23 @@ subroutine psb_cspalloc(a, desc_a, info, nnz) if (present(nnz))then if (nnz < 0) then info=45 - int_err(1)=7 - int_err(2)=nnz - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/7_psb_ipk_,nnz/)) goto 9999 endif - length_ia1=nnz - length_ia2=nnz + nnz_ = nnz else - length_ia1=max(1,5*loc_row) + nnz_ = max(1,5*loc_row) endif if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1 + & write(debug_unit,*) me,' ',trim(name), & + & ':allocating size:',loc_row,loc_col,nnz_ call a%free() !....allocate aspk, ia1, ia2..... - call a%csall(loc_row,loc_col,info,nz=length_ia1) + call a%csall(loc_row,loc_col,info,nz=nnz_) if(info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='sp_all' - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,a_err='sp_all') goto 9999 end if diff --git a/base/tools/psb_cspasb.f90 b/base/tools/psb_cspasb.f90 index cc24c5942..ae5c0af2c 100644 --- a/base/tools/psb_cspasb.f90 +++ b/base/tools/psb_cspasb.f90 @@ -62,15 +62,12 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl, mold) character(len=*), optional, intent(in) :: afmt class(psb_c_base_sparse_mat), intent(in), optional :: mold !....Locals.... - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: np,me,n_col, err_act - integer(psb_ipk_) :: spstate - integer(psb_ipk_) :: ictxt,n_row + integer(psb_ipk_) :: ictxt,np,me, err_act + integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err info = psb_success_ - int_err(1)=0 name = 'psb_spasb' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() diff --git a/base/tools/psb_cspfree.f90 b/base/tools/psb_cspfree.f90 index e501f597b..6defa911e 100644 --- a/base/tools/psb_cspfree.f90 +++ b/base/tools/psb_cspfree.f90 @@ -51,10 +51,12 @@ subroutine psb_cspfree(a, desc_a,info) integer(psb_ipk_) :: ictxt, err_act character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_cspfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (.not.psb_is_ok_desc(desc_a)) then info = psb_err_forgot_spall_ diff --git a/base/tools/psb_csphalo.F90 b/base/tools/psb_csphalo.F90 index 44f25b678..f8008bf85 100644 --- a/base/tools/psb_csphalo.F90 +++ b/base/tools/psb_csphalo.F90 @@ -75,15 +75,22 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: np,me,counter,proc,i, & - & n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,& + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: counter,proc,i, & + & n_el_send,k,n_el_recv,idx, r, tot_elem,& & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & irmin,icmin,irmax,icmax,data_,ngtz,totxch,nxs, nxr,& & l1, err_act - integer(psb_mpik_) :: icomm, minfo - integer(psb_mpik_), allocatable :: brvindx(:), & + integer(psb_mpk_) :: icomm, minfo + integer(psb_mpk_), allocatable :: brvindx(:), & & rvsz(:), bsdindx(:),sdsz(:) +#if defined(IPK4) && defined(LPK8) + ! If globals are 8 bytes but locals are 4, things get tricky + integer(psb_ipk_), allocatable :: liasnd(:), ljasnd(:) + integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:), iarcv(:), jarcv(:) +#else integer(psb_ipk_), allocatable :: iasnd(:), jasnd(:) +#endif complex(psb_spk_), allocatable :: valsnd(:) type(psb_c_coo_sparse_mat), allocatable :: acoo integer(psb_ipk_), pointer :: idxv(:) @@ -94,10 +101,12 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err - if(psb_get_errstatus() /= 0) return info=psb_success_ name='psb_csphalo' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -152,6 +161,7 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& If (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + select case(data_) case(psb_comm_halo_,psb_comm_ext_ ) ! Do not accept OVRLAP_INDEX any longer. @@ -172,7 +182,7 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& idxs = 0 idxr = 0 - call acoo%allocate(izero,a%get_ncols(),info) + call acoo%allocate(izero,a%get_ncols()) call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info) @@ -195,8 +205,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& counter = counter+n_el_send+3 Enddo - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& - & rvsz,1,psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') @@ -225,14 +235,417 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_reall') - goto 9999 - end if mat_recv = iszr iszs=sum(sdsz) - call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) +#if defined(IPK4) && defined(LPK8) + ! If globals are 8 bytes but locals are not, things get tricky + if (info == psb_success_) call psb_ensure_size(max(iszs,1),liasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),ljasnd,info) + + if (info == psb_success_) call psb_ensure_size(max(iszr,1),iarcv,info) + if (info == psb_success_) call psb_ensure_size(max(iszr,1),jarcv,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv=ipdxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=ipdxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + call a%csget(idx,idx,ngtz,liasnd,ljasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + ipx = ipx + 1 + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) then + call psb_loc_to_glob(liasnd(1:nz),iasnd(1:nz),desc_a,info,iact='I') + else + iasnd(1:nz) = liasnd(1:nz) + end if + if (colcnv_) then + call psb_loc_to_glob(ljasnd(1:nz),jasnd(1:nz),desc_a,info,iact='I') + else + jasnd(1:nz) = ljasnd(1:nz) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& + & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & iarcv,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & jarcv,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) then + call psb_glob_to_loc(iarcv(1:iszr),acoo%ia(1:iszr),desc_a,info,iact='I') + else + acoo%ia(1:iszr) = iarcv(1:iszr) + end if + if (colcnv_) then + call psb_glob_to_loc(jarcv(1:iszr),acoo%ja(1:iszr),desc_a,info,iact='I') + else + acoo%ja(1:iszr) = jarcv(1:iszr) + end if + +#else + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv=ipdxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=ipdxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + ipx = ipx + 1 + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') + if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& + & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_,& + & acoo%ia,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_,& + & acoo%ja,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') + if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') +#endif + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psbglob_to_loc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + l1 = 0 + call acoo%set_nrows(izero) + ! + irmin = huge(irmin) + icmin = huge(icmin) + irmax = 0 + icmax = 0 + Do i=1,iszr + r=(acoo%ia(i)) + k=(acoo%ja(i)) + ! Just in case some of the conversions were out-of-range + If ((r>0).and.(k>0)) Then + l1=l1+1 + acoo%val(l1) = acoo%val(i) + acoo%ia(l1) = r + acoo%ja(l1) = k + irmin = min(irmin,r) + irmax = max(irmax,r) + icmin = min(icmin,k) + icmax = max(icmax,k) + End If + Enddo + if (rowscale_) then + call acoo%set_nrows(max(irmax-irmin+1,0)) + acoo%ia(1:l1) = acoo%ia(1:l1) - irmin + 1 + else + call acoo%set_nrows(irmax) + end if + if (colscale_) then + call acoo%set_ncols(max(icmax-icmin+1,0)) + acoo%ja(1:l1) = acoo%ja(1:l1) - icmin + 1 + else + call acoo%set_ncols(icmax) + end if + + call acoo%set_nzeros(l1) + call acoo%set_sorted(.false.) + + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': End data exchange',counter,l1 + + call move_alloc(acoo,blk%a) + + ! Do we expect any duplicates to appear???? + call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spcnv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Deallocate(brvindx,bsdindx,rvsz,sdsz,& + & iasnd,jasnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +End Subroutine psb_csphalo + + +Subroutine psb_lcsphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + use psb_base_mod, psb_protect_name => psb_lcsphalo + +#ifdef MPI_MOD + use mpi +#endif + Implicit None +#ifdef MPI_H + include 'mpif.h' +#endif + + Type(psb_lcspmat_type),Intent(in) :: a + Type(psb_lcspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer(psb_ipk_), intent(in), optional :: data + ! ...local scalars.... + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: counter, proc, i, & + & n_el_send,n_el_recv,& + & n_elem, j, ipx,mat_recv, idxs,idxr,nz,& + & data_,totxch,nxs, nxr + integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, & + & lidx, l1, lnr, lnc, idx, ngtz, tot_elem + integer(psb_mpk_) :: icomm, minfo + integer(psb_mpk_), allocatable :: brvindx(:), & + & rvsz(:), bsdindx(:),sdsz(:) + integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) + complex(psb_spk_), allocatable :: valsnd(:) + type(psb_lc_coo_sparse_mat), allocatable :: acoo + integer(psb_ipk_), pointer :: idxv(:) + class(psb_i_base_vect_type), pointer :: pdxv + integer(psb_ipk_), allocatable :: ipdxv(:) + logical :: rowcnv_,colcnv_,rowscale_,colscale_ + character(len=5) :: outfmt_ + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_csphalo' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + Call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Start' + + if (present(rowcnv)) then + rowcnv_ = rowcnv + else + rowcnv_ = .true. + endif + if (present(colcnv)) then + colcnv_ = colcnv + else + colcnv_ = .true. + endif + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .false. + endif + if (present(colscale)) then + colscale_ = colscale + else + colscale_ = .false. + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + if (present(outfmt)) then + outfmt_ = psb_toupper(outfmt) + else + outfmt_ = 'CSR' + endif + + Allocate(brvindx(np+1),& + & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + If (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + + select case(data_) + case(psb_comm_halo_,psb_comm_ext_ ) + ! Do not accept OVRLAP_INDEX any longer. + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector') + goto 9999 + end select + + + sdsz(:)=0 + rvsz(:)=0 + l1 = 0 + ipx = 1 + brvindx(ipx) = 0 + bsdindx(ipx) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + lnc = a%get_ncols() + call acoo%allocate(lzero,lnc) + + + call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info) + ipdxv = pdxv%get_vect() + ! For all rows in the halo descriptor, extract and send/receive. + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv = ipdxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = ipdxv(counter+psb_n_elem_send_) + tot_elem = 0 + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + tot_elem = tot_elem+n_elem + Enddo + sdsz(proc+1) = tot_elem + call acoo%set_nrows(acoo%get_nrows() + n_el_recv) + counter = counter+n_el_send+3 + Enddo + + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv = ipdxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = ipdxv(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_el_send+3 + Enddo + + iszr=sum(rvsz) + call acoo%reallocate(max(iszr,1)) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& + & ' Send:',sdsz(:),' Receive:',rvsz(:) + mat_recv = iszr + iszs=sum(sdsz) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) if (info /= psb_success_) then @@ -241,6 +654,11 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& goto 9999 end if + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + l1 = 0 ipx = 1 counter=1 @@ -282,10 +700,10 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_spk_,icomm,minfo) - call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& - & acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) - call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& - & acoo%ja,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') @@ -297,7 +715,6 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') - if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psbglob_to_loc') @@ -305,7 +722,7 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& end if l1 = 0 - call acoo%set_nrows(izero) + call acoo%set_nrows(lzero) ! irmin = huge(irmin) icmin = huge(icmin) @@ -368,4 +785,4 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,& return -End Subroutine psb_csphalo +End Subroutine psb_lcsphalo diff --git a/base/tools/psb_cspins.f90 b/base/tools/psb_cspins.f90 index 5b343b8f9..2855bc1ea 100644 --- a/base/tools/psb_cspins.f90 +++ b/base/tools/psb_cspins.f90 @@ -56,10 +56,11 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !....parameters... type(psb_desc_type), intent(inout) :: desc_a type(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: rebuild, local + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: rebuild, local !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate @@ -68,7 +69,6 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -122,9 +122,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if @@ -133,9 +132,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & mask=(ila(1:nz)>0)) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if nrow = desc_a%get_local_rows() @@ -159,31 +157,24 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() + allocate(ila(nz),jla(nz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate',i_err=(/info/)) + goto 9999 + end if if (local_) then - call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + ila(1:nz) = ia(1:nz) + jla(1:nz) = ja(1:nz) else - allocate(ila(nz),jla(nz),stat=info) - if (info /= psb_success_) then - ierr(1) = info - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) - goto 9999 - end if - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info) if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info) - - call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + end if + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 end if else info = psb_err_invalid_cd_state_ @@ -210,9 +201,10 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) type(psb_desc_type), intent(in) :: desc_ar type(psb_desc_type), intent(inout) :: desc_ac type(psb_cspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) complex(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate @@ -220,7 +212,6 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -268,9 +259,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if @@ -279,9 +269,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) & mask=(ila(1:nz)>0)) if (psb_errstatus_fatal()) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if @@ -327,7 +316,7 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) type(psb_desc_type), intent(inout) :: desc_a type(psb_cspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz - type(psb_i_vect_type), intent(inout) :: ia,ja + type(psb_l_vect_type), intent(inout) :: ia,ja type(psb_c_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild, local @@ -340,7 +329,6 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -394,9 +382,8 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) else allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if if (ia%is_dev()) call ia%sync() @@ -407,9 +394,8 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) call desc_a%indxmap%g2l_ins(ja%v%v(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0)) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if nrow = desc_a%get_local_rows() @@ -433,33 +419,28 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() + allocate(ila(nz),jla(nz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate',i_err=(/info/)) + goto 9999 + end if + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + if (val%is_dev()) call val%sync() + if (local_) then - call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + ila(1:nz) = ia%v%v(1:nz) + jla(1:nz) = ja%v%v(1:nz) else - allocate(ila(nz),jla(nz),stat=info) - if (info /= psb_success_) then - ierr(1) = info - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) - goto 9999 - end if - if (ia%is_dev()) call ia%sync() - if (ja%is_dev()) call ja%sync() - if (val%is_dev()) call val%sync() - call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info) if (info == 0) call desc_a%indxmap%g2l(ja%v%v(1:nz),jla(1:nz),info) - if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + end if + if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 end if else info = psb_err_invalid_cd_state_ diff --git a/base/tools/psb_csprn.f90 b/base/tools/psb_csprn.f90 index f5f1d0fdd..3912cdae7 100644 --- a/base/tools/psb_csprn.f90 +++ b/base/tools/psb_csprn.f90 @@ -53,15 +53,12 @@ Subroutine psb_csprn(a, desc_a,info,clear) logical, intent(in), optional :: clear !locals - integer(psb_ipk_) :: ictxt,np,me,err,err_act + integer(psb_ipk_) :: ictxt,np,me,err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: int_err(5) character(len=20) :: name logical :: clear_ info = psb_success_ - err = 0 - int_err(1)=0 name = 'psb_csprn' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() diff --git a/base/tools/psb_d_map.f90 b/base/tools/psb_d_map.f90 index 22e2ceb5a..6f1519213 100644 --- a/base/tools/psb_d_map.f90 +++ b/base/tools/psb_d_map.f90 @@ -401,7 +401,7 @@ function psb_d_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) & type(psb_desc_type), target :: desc_X, desc_Y type(psb_dspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) ! integer(psb_ipk_) :: info character(len=20), parameter :: name='psb_linmap' diff --git a/base/tools/psb_dallc.f90 b/base/tools/psb_dallc.f90 index 844af0681..ac812ca78 100644 --- a/base/tools/psb_dallc.f90 +++ b/base/tools/psb_dallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_dalloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_dalloc - use psi_mod - implicit none - - !....parameters... - real(psb_dpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)') - goto 9999 - endif - - x(:,:) = dzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dalloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Function: psb_dallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_dallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_dallocv - use psi_mod - implicit none - - !....parameters... - real(psb_dpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)') - goto 9999 - endif - - x(:) = dzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dallocv - - subroutine psb_dalloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_dalloc_vect use psi_mod @@ -258,7 +55,7 @@ subroutine psb_dalloc_vect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: ictxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -295,7 +92,7 @@ subroutine psb_dalloc_vect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -303,8 +100,7 @@ subroutine psb_dalloc_vect(x, desc_a,info,n) if (info == 0) call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif call x%zero() @@ -331,7 +127,7 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -378,8 +174,7 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -392,7 +187,7 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -407,8 +202,7 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb) end if if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif @@ -435,7 +229,7 @@ subroutine psb_dalloc_multivect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -477,8 +271,7 @@ subroutine psb_dalloc_multivect(x, desc_a,info,n) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -491,7 +284,7 @@ subroutine psb_dalloc_multivect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -501,8 +294,7 @@ subroutine psb_dalloc_multivect(x, desc_a,info,n) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif diff --git a/base/tools/psb_dallc_a.f90 b/base/tools/psb_dallc_a.f90 new file mode 100644 index 000000000..b9fcf1147 --- /dev/null +++ b/base/tools/psb_dallc_a.f90 @@ -0,0 +1,246 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_dallc.f90 +! +! Function: psb_dalloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_dalloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_dalloc + use psi_mod + implicit none + + !....parameters... + real(psb_dpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: err,nr,i,j,n_,err_act + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: exch(3) + character(len=20) :: name + + name='psb_geall' + info = psb_success_ + err = 0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr*n_/),a_err='real(psb_dpk_)') + goto 9999 + endif + + x(:,:) = dzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dalloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Function: psb_dallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_dallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_dallocv + use psi_mod + implicit none + + !....parameters... + real(psb_dpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: nr,i,err_act + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_dpk_)') + goto 9999 + endif + + x(:) = dzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dallocv + diff --git a/base/tools/psb_dasb.f90 b/base/tools/psb_dasb.f90 index 93dc226e6..3a022b1c4 100644 --- a/base/tools/psb_dasb.f90 +++ b/base/tools/psb_dasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - real, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_dasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_dasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_dgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_dasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - real, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_dasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_dasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - real(psb_dpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_dgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dasbv - - subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_dasb_vect implicit none @@ -266,7 +54,7 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -274,7 +62,6 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_dgeasb_v' ictxt = desc_a%get_context() @@ -340,7 +127,7 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me, i, n - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -348,7 +135,6 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_dgeasb_v' ictxt = desc_a%get_context() @@ -423,7 +209,7 @@ subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -432,7 +218,6 @@ subroutine psb_dasb_multivect(x, desc_a, info, mold, scratch,n) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_dgeasb' ictxt = desc_a%get_context() diff --git a/base/tools/psb_dasb_a.f90 b/base/tools/psb_dasb_a.f90 new file mode 100644 index 000000000..42a60fbf1 --- /dev/null +++ b/base/tools/psb_dasb_a.f90 @@ -0,0 +1,259 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dasb.f90 +! +! Subroutine: psb_dasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - real, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_dasb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_dasb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_dgeasb_m' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dasb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_dasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - real, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_dasbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_dasbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_dpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'psb_dgeasb_v' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dasbv diff --git a/base/tools/psb_dcdbldext.F90 b/base/tools/psb_dcdbldext.F90 index 99610cc36..584a1f256 100644 --- a/base/tools/psb_dcdbldext.F90 +++ b/base/tools/psb_dcdbldext.F90 @@ -84,18 +84,20 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) integer(psb_ipk_) :: i, j, err_act,m,& & lovr, lworks,lworkr, n_row,n_col, n_col_prev, & & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo - integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,& + integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e, & & idx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ - integer(psb_mpik_) :: icomm, ictxt, me, np, minfo + integer(psb_lpk_) :: gidx, lnz + integer(psb_mpk_) :: icomm, ictxt, me, np, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) - integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),works(:),workr(:),& + integer(psb_lpk_), allocatable :: works(:),workr(:) + integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),& & t_halo_in(:), t_halo_out(:),temp(:),maskr(:) - integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) + integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -262,13 +264,13 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - orig_ovr(cntov_o)=proc - orig_ovr(cntov_o+1)=1 - orig_ovr(cntov_o+2)=idx - orig_ovr(cntov_o+3)=-1 + orig_ovr(cntov_o) = proc + orig_ovr(cntov_o+1) = 1 + orig_ovr(cntov_o+2) = idx + orig_ovr(cntov_o+3) = -1 cntov_o=cntov_o+3 end Do - counter=counter+n_elem_recv+n_elem_send+3 + counter = counter+n_elem_recv+n_elem_send+3 end Do @@ -319,16 +321,16 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) n_col_prev = desc_ov%get_local_cols() Do While (halo(counter) /= -1) - tot_elem=0 - proc=halo(counter+psb_proc_id_) - n_elem_recv=halo(counter+psb_n_elem_recv_) - n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) + tot_elem = 0 + proc = halo(counter+psb_proc_id_) + n_elem_recv = halo(counter+psb_n_elem_recv_) + n_elem_send = halo(counter+n_elem_recv+psb_n_elem_send_) If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then info = -1 call psb_errpush(info,name) goto 9999 end If - tot_recv=tot_recv+n_elem_recv + tot_recv = tot_recv+n_elem_recv if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ': tot_recv:',proc,n_elem_recv,tot_recv @@ -407,6 +409,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! If (i_ovr <= (novr)) Then call a%csget(idx,idx,n_elem,irow,icol,info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='csget') @@ -431,8 +434,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) if (i_ovr <= novr) then if (tot_elem > 1) then - call psb_msort_unique(works(idxs+1:idxs+tot_elem),i) - tot_elem=i + call psb_msort_unique(works(idxs+1:idxs+tot_elem),lnz) + tot_elem = lnz endif sdsz(proc+1) = tot_elem @@ -451,8 +454,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) ! accumulated RECV requests, we have an all-to-all to build ! matchings SENDs. ! - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, & - & psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,rvsz,1, & + & psb_mpi_mpk_,icomm,minfo) if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') @@ -487,8 +490,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) lworkr = max(iszr,1) end if - call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_ipk_integer,& - & workr,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_lpk_,& + & workr,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') @@ -514,12 +517,13 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) j = 0 do i=1,iszr if (maskr(i) < 0) then - j=j+1 + j = j+1 works(j) = workr(i) end if end do ! Eliminate duplicates from request - call psb_msort_unique(works(1:j),iszs) + call psb_msort_unique(works(1:j),lnz) + iszs = lnz ! ! fnd_owner on desc_a because we want the procs who @@ -536,9 +540,9 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) & ': Done fnd_owner', desc_ov%indxmap%get_state() do i=1,iszs - idx = works(i) - n_col = desc_ov%get_local_cols() - call desc_ov%indxmap%g2l_ins(idx,lidx,info) + gidx = works(i) + n_col = desc_ov%get_local_cols() + call desc_ov%indxmap%g2l_ins(gidx,lidx,info) if (desc_ov%get_local_cols() > n_col ) then ! ! This is a new index. Assigning a local index as @@ -640,7 +644,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 end if orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) - cntov_o = cntov_o+counter_o-1 + cntov_o = cntov_o+counter_o-1 orig_ovr(cntov_o:) = -1 call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) deallocate(tmp_ovr_idx,stat=info) diff --git a/base/tools/psb_dfree.f90 b/base/tools/psb_dfree.f90 index 0c366394c..6c36dd097 100644 --- a/base/tools/psb_dfree.f90 +++ b/base/tools/psb_dfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - real, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_dfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_dfree - implicit none - - !....parameters... - real(psb_dpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_dfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dfree - - - -! Subroutine: psb_dfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - real, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_dfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_dfreev - implicit none - !....parameters... - real(psb_dpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_dfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dfreev - subroutine psb_dfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_dfree_vect implicit none diff --git a/base/tools/psb_dfree_a.f90 b/base/tools/psb_dfree_a.f90 new file mode 100644 index 000000000..a33c41be3 --- /dev/null +++ b/base/tools/psb_dfree_a.f90 @@ -0,0 +1,164 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_dfree.f90 +! +! Subroutine: psb_dfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_dfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_dfree + implicit none + + !....parameters... + real(psb_dpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_dfree' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dfree + + + +! Subroutine: psb_dfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_dfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_dfreev + implicit none + !....parameters... + real(psb_dpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_dfreev' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dfreev diff --git a/base/tools/psb_dins.f90 b/base/tools/psb_dins.f90 index 8c606b8d6..84d5a0150 100644 --- a/base/tools/psb_dins.f90 +++ b/base/tools/psb_dins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_dinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_dpk_), intent(in) :: val(:) - real(psb_dpk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_dinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dinsvi - - subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_dins_vect use psi_mod @@ -189,7 +56,7 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_dpk_), intent(in) :: val(:) type(psb_d_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -198,9 +65,9 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -228,15 +95,11 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -303,7 +166,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_d_vect_type), intent(inout) :: val type(psb_d_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -312,9 +175,9 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) real(psb_dpk_), allocatable :: lval(:) logical :: local_ @@ -343,15 +206,11 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -379,15 +238,14 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local) local_ = .false. endif + if (irw%is_dev()) call irw%sync() if (local_) then - call x%ins(m,irw,val,dupl_,info) + irl(1:m) = irw%v%v(1:m) else - irl = irw%get_vect() - lval = val%get_vect() - call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.) - call x%ins(m,irl,lval,dupl_,info) - + call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if + + call x%ins(m,irl,lval,dupl_,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -413,7 +271,7 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_dpk_), intent(in) :: val(:,:) type(psb_d_vect_type), intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a @@ -422,9 +280,9 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5), n - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols, n + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -457,15 +315,11 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x(1)%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -523,197 +377,6 @@ end subroutine psb_dins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_dinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - real The source dense submatrix. -! x(:,:) - real The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_dinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_dpk_), intent(in) :: val(:,:) - real(psb_dpk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_dinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_dinsi - - - subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_dins_multivect use psi_mod @@ -725,7 +388,7 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_dpk_), intent(in) :: val(:,:) type(psb_d_multivect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -734,9 +397,9 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -764,15 +427,11 @@ subroutine psb_dins_multivect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif diff --git a/base/tools/psb_dins_a.f90 b/base/tools/psb_dins_a.f90 new file mode 100644 index 000000000..9aee33bd8 --- /dev/null +++ b/base/tools/psb_dins_a.f90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psb_dinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - real The source dense submatrix. +! x(:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_dinsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:) + real(psb_dpk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_dinsvi' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dinsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_dinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - real The source dense submatrix. +! x(:,:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_dinsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + real(psb_dpk_), intent(in) :: val(:,:) + real(psb_dpk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_dinsi' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_dinsi + diff --git a/base/tools/psb_dspalloc.f90 b/base/tools/psb_dspalloc.f90 index 34a329db4..9ae4572ac 100644 --- a/base/tools/psb_dspalloc.f90 +++ b/base/tools/psb_dspalloc.f90 @@ -52,16 +52,17 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) integer(psb_ipk_), optional, intent(in) :: nnz !locals - integer(psb_ipk_) :: ictxt, dectype - integer(psb_ipk_) :: np,me,loc_row,loc_col,& - & length_ia1,length_ia2, err_act,m,n - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ictxt, np, me, err_act + integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype + integer(psb_lpk_) :: m, n integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if name = 'psb_dspall' debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -87,26 +88,23 @@ subroutine psb_dspalloc(a, desc_a, info, nnz) if (present(nnz))then if (nnz < 0) then info=45 - int_err(1)=7 - int_err(2)=nnz - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/7_psb_ipk_,nnz/)) goto 9999 endif - length_ia1=nnz - length_ia2=nnz + nnz_ = nnz else - length_ia1=max(1,5*loc_row) + nnz_ = max(1,5*loc_row) endif if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1 + & write(debug_unit,*) me,' ',trim(name), & + & ':allocating size:',loc_row,loc_col,nnz_ call a%free() !....allocate aspk, ia1, ia2..... - call a%csall(loc_row,loc_col,info,nz=length_ia1) + call a%csall(loc_row,loc_col,info,nz=nnz_) if(info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='sp_all' - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,a_err='sp_all') goto 9999 end if diff --git a/base/tools/psb_dspasb.f90 b/base/tools/psb_dspasb.f90 index 1e25e43c0..c2434c09c 100644 --- a/base/tools/psb_dspasb.f90 +++ b/base/tools/psb_dspasb.f90 @@ -62,15 +62,12 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold) character(len=*), optional, intent(in) :: afmt class(psb_d_base_sparse_mat), intent(in), optional :: mold !....Locals.... - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: np,me,n_col, err_act - integer(psb_ipk_) :: spstate - integer(psb_ipk_) :: ictxt,n_row + integer(psb_ipk_) :: ictxt,np,me, err_act + integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err info = psb_success_ - int_err(1)=0 name = 'psb_spasb' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() diff --git a/base/tools/psb_dspfree.f90 b/base/tools/psb_dspfree.f90 index 46740558b..ee8388ce9 100644 --- a/base/tools/psb_dspfree.f90 +++ b/base/tools/psb_dspfree.f90 @@ -51,10 +51,12 @@ subroutine psb_dspfree(a, desc_a,info) integer(psb_ipk_) :: ictxt, err_act character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_dspfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (.not.psb_is_ok_desc(desc_a)) then info = psb_err_forgot_spall_ diff --git a/base/tools/psb_dsphalo.F90 b/base/tools/psb_dsphalo.F90 index dbc12c026..c2aa25389 100644 --- a/base/tools/psb_dsphalo.F90 +++ b/base/tools/psb_dsphalo.F90 @@ -75,15 +75,22 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: np,me,counter,proc,i, & - & n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,& + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: counter,proc,i, & + & n_el_send,k,n_el_recv,idx, r, tot_elem,& & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & irmin,icmin,irmax,icmax,data_,ngtz,totxch,nxs, nxr,& & l1, err_act - integer(psb_mpik_) :: icomm, minfo - integer(psb_mpik_), allocatable :: brvindx(:), & + integer(psb_mpk_) :: icomm, minfo + integer(psb_mpk_), allocatable :: brvindx(:), & & rvsz(:), bsdindx(:),sdsz(:) +#if defined(IPK4) && defined(LPK8) + ! If globals are 8 bytes but locals are 4, things get tricky + integer(psb_ipk_), allocatable :: liasnd(:), ljasnd(:) + integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:), iarcv(:), jarcv(:) +#else integer(psb_ipk_), allocatable :: iasnd(:), jasnd(:) +#endif real(psb_dpk_), allocatable :: valsnd(:) type(psb_d_coo_sparse_mat), allocatable :: acoo integer(psb_ipk_), pointer :: idxv(:) @@ -94,10 +101,12 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err - if(psb_get_errstatus() /= 0) return info=psb_success_ name='psb_dsphalo' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -152,6 +161,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& If (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + select case(data_) case(psb_comm_halo_,psb_comm_ext_ ) ! Do not accept OVRLAP_INDEX any longer. @@ -172,7 +182,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& idxs = 0 idxr = 0 - call acoo%allocate(izero,a%get_ncols(),info) + call acoo%allocate(izero,a%get_ncols()) call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info) @@ -195,8 +205,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& counter = counter+n_el_send+3 Enddo - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& - & rvsz,1,psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') @@ -225,14 +235,417 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_reall') - goto 9999 - end if mat_recv = iszr iszs=sum(sdsz) - call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) +#if defined(IPK4) && defined(LPK8) + ! If globals are 8 bytes but locals are not, things get tricky + if (info == psb_success_) call psb_ensure_size(max(iszs,1),liasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),ljasnd,info) + + if (info == psb_success_) call psb_ensure_size(max(iszr,1),iarcv,info) + if (info == psb_success_) call psb_ensure_size(max(iszr,1),jarcv,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv=ipdxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=ipdxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + call a%csget(idx,idx,ngtz,liasnd,ljasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + ipx = ipx + 1 + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) then + call psb_loc_to_glob(liasnd(1:nz),iasnd(1:nz),desc_a,info,iact='I') + else + iasnd(1:nz) = liasnd(1:nz) + end if + if (colcnv_) then + call psb_loc_to_glob(ljasnd(1:nz),jasnd(1:nz),desc_a,info,iact='I') + else + jasnd(1:nz) = ljasnd(1:nz) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& + & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & iarcv,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & jarcv,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) then + call psb_glob_to_loc(iarcv(1:iszr),acoo%ia(1:iszr),desc_a,info,iact='I') + else + acoo%ia(1:iszr) = iarcv(1:iszr) + end if + if (colcnv_) then + call psb_glob_to_loc(jarcv(1:iszr),acoo%ja(1:iszr),desc_a,info,iact='I') + else + acoo%ja(1:iszr) = jarcv(1:iszr) + end if + +#else + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv=ipdxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=ipdxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + ipx = ipx + 1 + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') + if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& + & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_,& + & acoo%ia,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_,& + & acoo%ja,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') + if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') +#endif + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psbglob_to_loc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + l1 = 0 + call acoo%set_nrows(izero) + ! + irmin = huge(irmin) + icmin = huge(icmin) + irmax = 0 + icmax = 0 + Do i=1,iszr + r=(acoo%ia(i)) + k=(acoo%ja(i)) + ! Just in case some of the conversions were out-of-range + If ((r>0).and.(k>0)) Then + l1=l1+1 + acoo%val(l1) = acoo%val(i) + acoo%ia(l1) = r + acoo%ja(l1) = k + irmin = min(irmin,r) + irmax = max(irmax,r) + icmin = min(icmin,k) + icmax = max(icmax,k) + End If + Enddo + if (rowscale_) then + call acoo%set_nrows(max(irmax-irmin+1,0)) + acoo%ia(1:l1) = acoo%ia(1:l1) - irmin + 1 + else + call acoo%set_nrows(irmax) + end if + if (colscale_) then + call acoo%set_ncols(max(icmax-icmin+1,0)) + acoo%ja(1:l1) = acoo%ja(1:l1) - icmin + 1 + else + call acoo%set_ncols(icmax) + end if + + call acoo%set_nzeros(l1) + call acoo%set_sorted(.false.) + + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': End data exchange',counter,l1 + + call move_alloc(acoo,blk%a) + + ! Do we expect any duplicates to appear???? + call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spcnv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Deallocate(brvindx,bsdindx,rvsz,sdsz,& + & iasnd,jasnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +End Subroutine psb_dsphalo + + +Subroutine psb_ldsphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + use psb_base_mod, psb_protect_name => psb_ldsphalo + +#ifdef MPI_MOD + use mpi +#endif + Implicit None +#ifdef MPI_H + include 'mpif.h' +#endif + + Type(psb_ldspmat_type),Intent(in) :: a + Type(psb_ldspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer(psb_ipk_), intent(in), optional :: data + ! ...local scalars.... + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: counter, proc, i, & + & n_el_send,n_el_recv,& + & n_elem, j, ipx,mat_recv, idxs,idxr,nz,& + & data_,totxch,nxs, nxr + integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, & + & lidx, l1, lnr, lnc, idx, ngtz, tot_elem + integer(psb_mpk_) :: icomm, minfo + integer(psb_mpk_), allocatable :: brvindx(:), & + & rvsz(:), bsdindx(:),sdsz(:) + integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) + real(psb_dpk_), allocatable :: valsnd(:) + type(psb_ld_coo_sparse_mat), allocatable :: acoo + integer(psb_ipk_), pointer :: idxv(:) + class(psb_i_base_vect_type), pointer :: pdxv + integer(psb_ipk_), allocatable :: ipdxv(:) + logical :: rowcnv_,colcnv_,rowscale_,colscale_ + character(len=5) :: outfmt_ + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_dsphalo' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + Call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Start' + + if (present(rowcnv)) then + rowcnv_ = rowcnv + else + rowcnv_ = .true. + endif + if (present(colcnv)) then + colcnv_ = colcnv + else + colcnv_ = .true. + endif + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .false. + endif + if (present(colscale)) then + colscale_ = colscale + else + colscale_ = .false. + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + if (present(outfmt)) then + outfmt_ = psb_toupper(outfmt) + else + outfmt_ = 'CSR' + endif + + Allocate(brvindx(np+1),& + & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + If (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + + select case(data_) + case(psb_comm_halo_,psb_comm_ext_ ) + ! Do not accept OVRLAP_INDEX any longer. + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector') + goto 9999 + end select + + + sdsz(:)=0 + rvsz(:)=0 + l1 = 0 + ipx = 1 + brvindx(ipx) = 0 + bsdindx(ipx) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + lnc = a%get_ncols() + call acoo%allocate(lzero,lnc) + + + call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info) + ipdxv = pdxv%get_vect() + ! For all rows in the halo descriptor, extract and send/receive. + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv = ipdxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = ipdxv(counter+psb_n_elem_send_) + tot_elem = 0 + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + tot_elem = tot_elem+n_elem + Enddo + sdsz(proc+1) = tot_elem + call acoo%set_nrows(acoo%get_nrows() + n_el_recv) + counter = counter+n_el_send+3 + Enddo + + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv = ipdxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = ipdxv(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_el_send+3 + Enddo + + iszr=sum(rvsz) + call acoo%reallocate(max(iszr,1)) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& + & ' Send:',sdsz(:),' Receive:',rvsz(:) + mat_recv = iszr + iszs=sum(sdsz) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) if (info /= psb_success_) then @@ -241,6 +654,11 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& goto 9999 end if + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + l1 = 0 ipx = 1 counter=1 @@ -282,10 +700,10 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_dpk_,icomm,minfo) - call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& - & acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) - call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& - & acoo%ja,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') @@ -297,7 +715,6 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') - if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psbglob_to_loc') @@ -305,7 +722,7 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& end if l1 = 0 - call acoo%set_nrows(izero) + call acoo%set_nrows(lzero) ! irmin = huge(irmin) icmin = huge(icmin) @@ -368,4 +785,4 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,& return -End Subroutine psb_dsphalo +End Subroutine psb_ldsphalo diff --git a/base/tools/psb_dspins.f90 b/base/tools/psb_dspins.f90 index 2a9997eaa..00d6a6af5 100644 --- a/base/tools/psb_dspins.f90 +++ b/base/tools/psb_dspins.f90 @@ -56,10 +56,11 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !....parameters... type(psb_desc_type), intent(inout) :: desc_a type(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: rebuild, local + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: rebuild, local !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate @@ -68,7 +69,6 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -122,9 +122,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if @@ -133,9 +132,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & mask=(ila(1:nz)>0)) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if nrow = desc_a%get_local_rows() @@ -159,31 +157,24 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() + allocate(ila(nz),jla(nz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate',i_err=(/info/)) + goto 9999 + end if if (local_) then - call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + ila(1:nz) = ia(1:nz) + jla(1:nz) = ja(1:nz) else - allocate(ila(nz),jla(nz),stat=info) - if (info /= psb_success_) then - ierr(1) = info - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) - goto 9999 - end if - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info) if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info) - - call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + end if + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 end if else info = psb_err_invalid_cd_state_ @@ -210,9 +201,10 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) type(psb_desc_type), intent(in) :: desc_ar type(psb_desc_type), intent(inout) :: desc_ac type(psb_dspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) real(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate @@ -220,7 +212,6 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -268,9 +259,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if @@ -279,9 +269,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) & mask=(ila(1:nz)>0)) if (psb_errstatus_fatal()) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if @@ -327,7 +316,7 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) type(psb_desc_type), intent(inout) :: desc_a type(psb_dspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz - type(psb_i_vect_type), intent(inout) :: ia,ja + type(psb_l_vect_type), intent(inout) :: ia,ja type(psb_d_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild, local @@ -340,7 +329,6 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -394,9 +382,8 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) else allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if if (ia%is_dev()) call ia%sync() @@ -407,9 +394,8 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) call desc_a%indxmap%g2l_ins(ja%v%v(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0)) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if nrow = desc_a%get_local_rows() @@ -433,33 +419,28 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() + allocate(ila(nz),jla(nz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate',i_err=(/info/)) + goto 9999 + end if + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + if (val%is_dev()) call val%sync() + if (local_) then - call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + ila(1:nz) = ia%v%v(1:nz) + jla(1:nz) = ja%v%v(1:nz) else - allocate(ila(nz),jla(nz),stat=info) - if (info /= psb_success_) then - ierr(1) = info - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) - goto 9999 - end if - if (ia%is_dev()) call ia%sync() - if (ja%is_dev()) call ja%sync() - if (val%is_dev()) call val%sync() - call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info) if (info == 0) call desc_a%indxmap%g2l(ja%v%v(1:nz),jla(1:nz),info) - if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + end if + if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 end if else info = psb_err_invalid_cd_state_ diff --git a/base/tools/psb_dsprn.f90 b/base/tools/psb_dsprn.f90 index f2ed83592..c5f81e488 100644 --- a/base/tools/psb_dsprn.f90 +++ b/base/tools/psb_dsprn.f90 @@ -53,15 +53,12 @@ Subroutine psb_dsprn(a, desc_a,info,clear) logical, intent(in), optional :: clear !locals - integer(psb_ipk_) :: ictxt,np,me,err,err_act + integer(psb_ipk_) :: ictxt,np,me,err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: int_err(5) character(len=20) :: name logical :: clear_ info = psb_success_ - err = 0 - int_err(1)=0 name = 'psb_dsprn' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() diff --git a/base/tools/psb_eallc_a.f90 b/base/tools/psb_eallc_a.f90 new file mode 100644 index 000000000..5f6e3c369 --- /dev/null +++ b/base/tools/psb_eallc_a.f90 @@ -0,0 +1,246 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_eallc.f90 +! +! Function: psb_ealloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_ealloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_ealloc + use psi_mod + implicit none + + !....parameters... + integer(psb_epk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: err,nr,i,j,n_,err_act + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: exch(3) + character(len=20) :: name + + name='psb_geall' + info = psb_success_ + err = 0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr*n_/),a_err='integer(psb_epk_)') + goto 9999 + endif + + x(:,:) = ezero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ealloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Function: psb_eallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_eallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_eallocv + use psi_mod + implicit none + + !....parameters... + integer(psb_epk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: nr,i,err_act + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='integer(psb_epk_)') + goto 9999 + endif + + x(:) = ezero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_eallocv + diff --git a/base/tools/psb_easb_a.f90 b/base/tools/psb_easb_a.f90 new file mode 100644 index 000000000..5c62aa59e --- /dev/null +++ b/base/tools/psb_easb_a.f90 @@ -0,0 +1,259 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_easb.f90 +! +! Subroutine: psb_easb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_easb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_easb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_egeasb_m' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_easb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_easb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_easbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_easbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_epk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'psb_egeasb_v' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_easbv diff --git a/base/tools/psb_efree_a.f90 b/base/tools/psb_efree_a.f90 new file mode 100644 index 000000000..c07ee694e --- /dev/null +++ b/base/tools/psb_efree_a.f90 @@ -0,0 +1,164 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_efree.f90 +! +! Subroutine: psb_efree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_efree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_efree + implicit none + + !....parameters... + integer(psb_epk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_efree' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_efree + + + +! Subroutine: psb_efreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_efreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_efreev + implicit none + !....parameters... + integer(psb_epk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_efreev' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_efreev diff --git a/base/tools/psb_eins_a.f90 b/base/tools/psb_eins_a.f90 new file mode 100644 index 000000000..3923a2654 --- /dev/null +++ b/base/tools/psb_eins_a.f90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psb_einsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - integer The source dense submatrix. +! x(:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_einsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_einsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_epk_), intent(in) :: val(:) + integer(psb_epk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_einsvi' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_einsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_einsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - integer The source dense submatrix. +! x(:,:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_einsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_einsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_epk_), intent(in) :: val(:,:) + integer(psb_epk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_einsi' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_einsi + diff --git a/base/tools/psb_glob_to_loc.f90 b/base/tools/psb_glob_to_loc.f90 index ad2640a5c..51b3f70d8 100644 --- a/base/tools/psb_glob_to_loc.f90 +++ b/base/tools/psb_glob_to_loc.f90 @@ -53,7 +53,7 @@ subroutine psb_glob_to_loc2v(x,y,desc_a,info,iact,owned) !...parameters.... type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(in) :: x(:) + integer(psb_lpk_), intent(in) :: x(:) integer(psb_ipk_), intent(out) :: y(:), info character, intent(in), optional :: iact logical, intent(in), optional :: owned @@ -174,7 +174,7 @@ subroutine psb_glob_to_loc1v(x,desc_a,info,iact,owned) !...parameters.... type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: owned character, intent(in), optional :: iact @@ -241,13 +241,14 @@ subroutine psb_glob_to_loc2s(x,y,desc_a,info,iact,owned) use psb_base_mod, psb_protect_name => psb_glob_to_loc2s implicit none type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(in) :: x + integer(psb_lpk_),intent(in) :: x integer(psb_ipk_),intent(out) :: y integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: iact logical, intent(in), optional :: owned - integer(psb_ipk_) :: iv1(1), iv2(1) + integer(psb_lpk_) :: iv1(1) + integer(psb_ipk_) :: iv2(1) iv1(1) = x call psb_glob_to_loc(iv1,iv2,desc_a,info,iact,owned) @@ -258,11 +259,11 @@ subroutine psb_glob_to_loc1s(x,desc_a,info,iact,owned) use psb_base_mod, psb_protect_name => psb_glob_to_loc1s implicit none type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x + integer(psb_lpk_),intent(inout) :: x integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: iact logical, intent(in), optional :: owned - integer(psb_ipk_) :: iv1(1) + integer(psb_lpk_) :: iv1(1) iv1(1) = x call psb_glob_to_loc(iv1,desc_a,info,iact,owned) diff --git a/base/tools/psb_iallc.f90 b/base/tools/psb_iallc.f90 index 7ec4e4bfd..8f0ab312c 100644 --- a/base/tools/psb_iallc.f90 +++ b/base/tools/psb_iallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_ialloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_ialloc - use psi_mod - implicit none - - !....parameters... - integer(psb_ipk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='integer(psb_ipk_)') - goto 9999 - endif - - x(:,:) = izero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_ialloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Function: psb_iallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_iallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_iallocv - use psi_mod - implicit none - - !....parameters... - integer(psb_ipk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='integer(psb_ipk_)') - goto 9999 - endif - - x(:) = izero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iallocv - - subroutine psb_ialloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_ialloc_vect use psi_mod @@ -258,7 +55,7 @@ subroutine psb_ialloc_vect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: ictxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -295,7 +92,7 @@ subroutine psb_ialloc_vect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -303,8 +100,7 @@ subroutine psb_ialloc_vect(x, desc_a,info,n) if (info == 0) call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif call x%zero() @@ -331,7 +127,7 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -378,8 +174,7 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -392,7 +187,7 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -407,8 +202,7 @@ subroutine psb_ialloc_vect_r2(x, desc_a,info,n,lb) end if if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif @@ -435,7 +229,7 @@ subroutine psb_ialloc_multivect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -477,8 +271,7 @@ subroutine psb_ialloc_multivect(x, desc_a,info,n) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -491,7 +284,7 @@ subroutine psb_ialloc_multivect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -501,8 +294,7 @@ subroutine psb_ialloc_multivect(x, desc_a,info,n) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif diff --git a/base/tools/psb_iasb.f90 b/base/tools/psb_iasb.f90 index 02d51425c..11bf80d71 100644 --- a/base/tools/psb_iasb.f90 +++ b/base/tools/psb_iasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - integer, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_iasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_iasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_igeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_iasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - integer, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_iasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_iasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_igeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iasbv - - subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_iasb_vect implicit none @@ -266,7 +54,7 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -274,7 +62,6 @@ subroutine psb_iasb_vect(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_igeasb_v' ictxt = desc_a%get_context() @@ -340,7 +127,7 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me, i, n - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -348,7 +135,6 @@ subroutine psb_iasb_vect_r2(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_igeasb_v' ictxt = desc_a%get_context() @@ -423,7 +209,7 @@ subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -432,7 +218,6 @@ subroutine psb_iasb_multivect(x, desc_a, info, mold, scratch,n) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_igeasb' ictxt = desc_a%get_context() diff --git a/base/tools/psb_icdasb.F90 b/base/tools/psb_icdasb.F90 index b10ec1c97..b1b2d5d7f 100644 --- a/base/tools/psb_icdasb.F90 +++ b/base/tools/psb_icdasb.F90 @@ -63,7 +63,7 @@ subroutine psb_icdasb(desc,info,ext_hv,mold) integer(psb_ipk_),allocatable :: ovrlap_index(:),halo_index(:), ext_index(:) integer(psb_ipk_) :: i, n_col, dectype, err_act, n_row - integer(psb_mpik_) :: np,me, icomm, ictxt + integer(psb_mpk_) :: np,me, icomm, ictxt logical :: ext_hv_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name diff --git a/base/tools/psb_ifree.f90 b/base/tools/psb_ifree.f90 index 65dfa3f8f..516f1219f 100644 --- a/base/tools/psb_ifree.f90 +++ b/base/tools/psb_ifree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - integer, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_ifree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_ifree - implicit none - - !....parameters... - integer(psb_ipk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_ifree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_ifree - - - -! Subroutine: psb_ifreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - integer, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_ifreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_ifreev - implicit none - !....parameters... - integer(psb_ipk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_ifreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_ifreev - subroutine psb_ifree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_ifree_vect implicit none diff --git a/base/tools/psb_iins.f90 b/base/tools/psb_iins.f90 index f98e27005..8b8eea7ec 100644 --- a/base/tools/psb_iins.f90 +++ b/base/tools/psb_iins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_iinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_iinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_ipk_), intent(in) :: val(:) - integer(psb_ipk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_iinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iinsvi - - subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_iins_vect use psi_mod @@ -189,7 +56,7 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) integer(psb_ipk_), intent(in) :: val(:) type(psb_i_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -198,9 +65,9 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -228,15 +95,11 @@ subroutine psb_iins_vect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -303,7 +166,7 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_i_vect_type), intent(inout) :: val type(psb_i_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -312,9 +175,9 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) integer(psb_ipk_), allocatable :: lval(:) logical :: local_ @@ -343,15 +206,11 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -379,15 +238,14 @@ subroutine psb_iins_vect_v(m, irw, val, x, desc_a, info, dupl,local) local_ = .false. endif + if (irw%is_dev()) call irw%sync() if (local_) then - call x%ins(m,irw,val,dupl_,info) + irl(1:m) = irw%v%v(1:m) else - irl = irw%get_vect() - lval = val%get_vect() - call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.) - call x%ins(m,irl,lval,dupl_,info) - + call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if + + call x%ins(m,irl,lval,dupl_,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -413,7 +271,7 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) integer(psb_ipk_), intent(in) :: val(:,:) type(psb_i_vect_type), intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a @@ -422,9 +280,9 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5), n - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols, n + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -457,15 +315,11 @@ subroutine psb_iins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x(1)%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -523,197 +377,6 @@ end subroutine psb_iins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_iinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - integer The source dense submatrix. -! x(:,:) - integer The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_iinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_iinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - integer(psb_ipk_), intent(in) :: val(:,:) - integer(psb_ipk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_iinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_iinsi - - - subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_iins_multivect use psi_mod @@ -725,7 +388,7 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) integer(psb_ipk_), intent(in) :: val(:,:) type(psb_i_multivect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -734,9 +397,9 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -764,15 +427,11 @@ subroutine psb_iins_multivect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif diff --git a/base/tools/psb_lallc.f90 b/base/tools/psb_lallc.f90 new file mode 100644 index 000000000..667311777 --- /dev/null +++ b/base/tools/psb_lallc.f90 @@ -0,0 +1,308 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_lallc.f90 +! +! Function: psb_lalloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_lalloc_vect(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_lalloc_vect + use psi_mod + implicit none + + !....parameters... + type(psb_l_vect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act + integer(psb_ipk_) :: ictxt + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(psb_l_base_vect_type :: x%v, stat=info) + if (info == 0) call x%all(nr,info) + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') + goto 9999 + endif + call x%zero() + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lalloc_vect + +subroutine psb_lalloc_vect_r2(x, desc_a,info,n,lb) + use psb_base_mod, psb_protect_name => psb_lalloc_vect_r2 + use psi_mod + implicit none + + !....parameters... + type(psb_l_vect_type), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n,lb + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ + integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + if (present(lb)) then + lb_ = lb + else + lb_ = 1 + endif + + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (desc_a%is_asb().or.desc_a%is_upd()) then + nr = max(1,desc_a%get_local_cols()) + else if (desc_a%is_bld()) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(x(lb_:lb_+n_-1), stat=info) + if (info == 0) then + do i=lb_, lb_+n_-1 + allocate(psb_l_base_vect_type :: x(i)%v, stat=info) + if (info == 0) call x(i)%all(nr,info) + if (info == 0) call x(i)%zero() + if (info /= 0) exit + end do + end if + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lalloc_vect_r2 + + +subroutine psb_lalloc_multivect(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_lalloc_multivect + use psi_mod + implicit none + + !....parameters... + type(psb_l_multivect_type), intent(out) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ + integer(psb_ipk_) :: ictxt, exch(1) + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + if (psb_errstatus_fatal()) return + name='psb_geall' + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (desc_a%is_asb().or.desc_a%is_upd()) then + nr = max(1,desc_a%get_local_cols()) + else if (desc_a%is_bld()) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + allocate(psb_l_base_multivect_type :: x%v, stat=info) + if (info == 0) call x%all(nr,n_,info) + if (info == 0) call x%zero() + + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') + goto 9999 + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lalloc_multivect diff --git a/base/tools/psb_lasb.f90 b/base/tools/psb_lasb.f90 new file mode 100644 index 000000000..8d3c7a97e --- /dev/null +++ b/base/tools/psb_lasb.f90 @@ -0,0 +1,285 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_lasb.f90 +! +! Subroutine: psb_lasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_lasb_vect(x, desc_a, info, mold, scratch) + use psb_base_mod, psb_protect_name => psb_lasb_vect + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + logical :: scratch_ + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + name = 'psb_lgeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + call x%free(info) + call x%bld(ncol,mold=mold) + else + call x%asb(ncol,info) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + call x%cnv(mold) + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lasb_vect + + +subroutine psb_lasb_vect_r2(x, desc_a, info, mold, scratch) + use psb_base_mod, psb_protect_name => psb_lasb_vect_r2 + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_vect_type), intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_vect_type), intent(in), optional :: mold + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me, i, n + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + logical :: scratch_ + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + name = 'psb_lgeasb_v' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + n = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + do i=1,n + call x(i)%free(info) + call x(i)%bld(ncol,mold=mold) + end do + + else + do i=1, n + call x(i)%asb(ncol,info) + if (info /= 0) exit + ! ..update halo elements.. + call psb_halo(x(i),desc_a,info) + if (info /= 0) exit + call x(i)%cnv(mold) + end do + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lasb_vect_r2 + + +subroutine psb_lasb_multivect(x, desc_a, info, mold, scratch,n) + use psb_base_mod, psb_protect_name => psb_lasb_multivect + implicit none + + type(psb_desc_type), intent(in) :: desc_a + type(psb_l_multivect_type), intent(inout) :: x + integer(psb_ipk_), intent(out) :: info + class(psb_l_base_multivect_type), intent(in), optional :: mold + integer(psb_ipk_), optional, intent(in) :: n + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ + logical :: scratch_ + + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name,ch_err + + info = psb_success_ + if (psb_errstatus_fatal()) return + + name = 'psb_lgeasb' + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (present(n)) then + n_ = n + else + if (allocated(x%v)) then + n_ = x%v%get_ncols() + else + n_ = 1 + end if + endif + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + + if (scratch_) then + call x%free(info) + call x%bld(ncol,n_,mold=mold) + else + call x%asb(ncol,n_,info) + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_halo') + goto 9999 + end if + if (present(mold)) then + call x%cnv(mold) + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lasb_multivect + diff --git a/base/tools/psb_lfree.f90 b/base/tools/psb_lfree.f90 new file mode 100644 index 000000000..d6c597a80 --- /dev/null +++ b/base/tools/psb_lfree.f90 @@ -0,0 +1,199 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_lfree.f90 +! +! Subroutine: psb_lfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_lfree_vect(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_lfree_vect + implicit none + !....parameters... + type(psb_l_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_lfreev' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call x%free(info) + + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lfree_vect + +subroutine psb_lfree_vect_r2(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_lfree_vect_r2 + implicit none + !....parameters... + type(psb_l_vect_type), allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act, i + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_lfreev' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + + do i=lbound(x,1),ubound(x,1) + call x(i)%free(info) + if (info /= 0) exit + end do + if (info == 0) deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lfree_vect_r2 + + +subroutine psb_lfree_multivect(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_lfree_multivect + implicit none + !....parameters... + type(psb_l_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + !...locals.... + integer(psb_ipk_) :: ictxt,np,me,err_act + character(len=20) :: name + + + info=psb_success_ + if (psb_errstatus_fatal()) return + call psb_erractionsave(err_act) + name='psb_lfree' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + call x%free(info) + + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lfree_multivect diff --git a/base/tools/psb_lins.f90 b/base/tools/psb_lins.f90 new file mode 100644 index 000000000..b0d020188 --- /dev/null +++ b/base/tools/psb_lins.f90 @@ -0,0 +1,490 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psb_linsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - integer The source dense submatrix. +! x(:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_lins_vect(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_lins_vect + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: val(:) + type(psb_l_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_linsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lins_vect + +subroutine psb_lins_vect_v(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_lins_vect_v + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + type(psb_l_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: val + type(psb_l_vect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + integer(psb_lpk_), allocatable :: lval(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_linsvi_vect_v' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (irw%is_dev()) call irw%sync() + if (local_) then + irl(1:m) = irw%v%v(1:m) + else + call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) + end if + + call x%ins(m,irl,lval,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lins_vect_v + +subroutine psb_lins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_lins_vect_r2 + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: val(:,:) + type(psb_l_vect_type), intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols, n + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_linsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x(1)%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (x(1)%get_nrows() < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + + + n = min(size(x),size(val,2)) + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + do i=1,n + if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_ + if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info) + if (info /= 0) exit + end do + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lins_vect_r2 + + + +subroutine psb_lins_multivect(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_lins_multivect + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: val(:,:) + type(psb_l_multivect_type), intent(inout) :: x + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_linsvi' + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (x%get_nrows() < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + call x%ins(m,irl,val,dupl_,info) + if (info /= 0) then + call psb_errpush(info,name) + goto 9999 + end if + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lins_multivect + + diff --git a/base/tools/psb_loc_to_glob.f90 b/base/tools/psb_loc_to_glob.f90 index fb40116d9..e4708b9d7 100644 --- a/base/tools/psb_loc_to_glob.f90 +++ b/base/tools/psb_loc_to_glob.f90 @@ -51,7 +51,7 @@ subroutine psb_loc_to_glob2v(x,y,desc_a,info,iact) !...parameters.... type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_), intent(in) :: x(:) - integer(psb_ipk_), intent(out) :: y(:) + integer(psb_lpk_), intent(out) :: y(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: iact @@ -156,7 +156,7 @@ subroutine psb_loc_to_glob1v(x,desc_a,info,iact) !...parameters.... type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(inout) :: x(:) + integer(psb_lpk_), intent(inout) :: x(:) integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: iact @@ -215,11 +215,12 @@ subroutine psb_loc_to_glob2s(x,y,desc_a,info,iact) implicit none type(psb_desc_type), intent(in) :: desc_a integer(psb_ipk_),intent(in) :: x - integer(psb_ipk_),intent(out) :: y + integer(psb_lpk_),intent(out) :: y integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: iact - integer(psb_ipk_) :: iv1(1), iv2(1) + integer(psb_ipk_) :: iv1(1) + integer(psb_lpk_) :: iv2(1) iv1(1) = x call psb_loc_to_glob(iv1,iv2,desc_a,info,iact) @@ -231,10 +232,10 @@ subroutine psb_loc_to_glob1s(x,desc_a,info,iact) use psb_tools_mod, psb_protect_name => psb_loc_to_glob1s implicit none type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(inout) :: x + integer(psb_lpk_),intent(inout) :: x integer(psb_ipk_), intent(out) :: info character, intent(in), optional :: iact - integer(psb_ipk_) :: iv1(1) + integer(psb_lpk_) :: iv1(1) iv1(1) = x call psb_loc_to_glob(iv1,desc_a,info,iact) diff --git a/base/tools/psb_mallc_a.f90 b/base/tools/psb_mallc_a.f90 new file mode 100644 index 000000000..2bcedc5bd --- /dev/null +++ b/base/tools/psb_mallc_a.f90 @@ -0,0 +1,246 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_mallc.f90 +! +! Function: psb_malloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_malloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_malloc + use psi_mod + implicit none + + !....parameters... + integer(psb_mpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: err,nr,i,j,n_,err_act + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: exch(3) + character(len=20) :: name + + name='psb_geall' + info = psb_success_ + err = 0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr*n_/),a_err='integer(psb_mpk_)') + goto 9999 + endif + + x(:,:) = mzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_malloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Function: psb_mallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_mallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_mallocv + use psi_mod + implicit none + + !....parameters... + integer(psb_mpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: nr,i,err_act + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='integer(psb_mpk_)') + goto 9999 + endif + + x(:) = mzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_mallocv + diff --git a/base/tools/psb_masb_a.f90 b/base/tools/psb_masb_a.f90 new file mode 100644 index 000000000..47c35d2a6 --- /dev/null +++ b/base/tools/psb_masb_a.f90 @@ -0,0 +1,259 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_masb.f90 +! +! Subroutine: psb_masb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_masb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_masb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_mgeasb_m' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_masb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_masb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - integer, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_masbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_masbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + integer(psb_mpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'psb_mgeasb_v' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_masbv diff --git a/base/tools/psb_mfree_a.f90 b/base/tools/psb_mfree_a.f90 new file mode 100644 index 000000000..49f255da9 --- /dev/null +++ b/base/tools/psb_mfree_a.f90 @@ -0,0 +1,164 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_mfree.f90 +! +! Subroutine: psb_mfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_mfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_mfree + implicit none + + !....parameters... + integer(psb_mpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_mfree' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_mfree + + + +! Subroutine: psb_mfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - integer, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_mfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_mfreev + implicit none + !....parameters... + integer(psb_mpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_mfreev' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_mfreev diff --git a/base/tools/psb_mins_a.f90 b/base/tools/psb_mins_a.f90 new file mode 100644 index 000000000..6d83b724e --- /dev/null +++ b/base/tools/psb_mins_a.f90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psb_minsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - integer The source dense submatrix. +! x(:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_minsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_minsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_mpk_), intent(in) :: val(:) + integer(psb_mpk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_minsvi' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_minsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_minsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - integer The source dense submatrix. +! x(:,:) - integer The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_minsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_minsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + integer(psb_mpk_), intent(in) :: val(:,:) + integer(psb_mpk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_minsi' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_minsi + diff --git a/base/tools/psb_s_map.f90 b/base/tools/psb_s_map.f90 index 511bc1ded..b5ea9b4fb 100644 --- a/base/tools/psb_s_map.f90 +++ b/base/tools/psb_s_map.f90 @@ -401,7 +401,7 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) & type(psb_desc_type), target :: desc_X, desc_Y type(psb_sspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) ! integer(psb_ipk_) :: info character(len=20), parameter :: name='psb_linmap' diff --git a/base/tools/psb_sallc.f90 b/base/tools/psb_sallc.f90 index 3852e67ed..9cbb6f8ff 100644 --- a/base/tools/psb_sallc.f90 +++ b/base/tools/psb_sallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_salloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_salloc - use psi_mod - implicit none - - !....parameters... - real(psb_spk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') - goto 9999 - endif - - x(:,:) = szero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_salloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Function: psb_sallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_sallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_sallocv - use psi_mod - implicit none - - !....parameters... - real(psb_spk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') - goto 9999 - endif - - x(:) = szero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sallocv - - subroutine psb_salloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_salloc_vect use psi_mod @@ -258,7 +55,7 @@ subroutine psb_salloc_vect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: ictxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -295,7 +92,7 @@ subroutine psb_salloc_vect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -303,8 +100,7 @@ subroutine psb_salloc_vect(x, desc_a,info,n) if (info == 0) call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif call x%zero() @@ -331,7 +127,7 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -378,8 +174,7 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -392,7 +187,7 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -407,8 +202,7 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb) end if if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif @@ -435,7 +229,7 @@ subroutine psb_salloc_multivect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -477,8 +271,7 @@ subroutine psb_salloc_multivect(x, desc_a,info,n) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -491,7 +284,7 @@ subroutine psb_salloc_multivect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -501,8 +294,7 @@ subroutine psb_salloc_multivect(x, desc_a,info,n) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif diff --git a/base/tools/psb_sallc_a.f90 b/base/tools/psb_sallc_a.f90 new file mode 100644 index 000000000..815acb616 --- /dev/null +++ b/base/tools/psb_sallc_a.f90 @@ -0,0 +1,246 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_sallc.f90 +! +! Function: psb_salloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_salloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_salloc + use psi_mod + implicit none + + !....parameters... + real(psb_spk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: err,nr,i,j,n_,err_act + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: exch(3) + character(len=20) :: name + + name='psb_geall' + info = psb_success_ + err = 0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr*n_/),a_err='real(psb_spk_)') + goto 9999 + endif + + x(:,:) = szero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_salloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Function: psb_sallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_sallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_sallocv + use psi_mod + implicit none + + !....parameters... + real(psb_spk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: nr,i,err_act + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') + goto 9999 + endif + + x(:) = szero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sallocv + diff --git a/base/tools/psb_sasb.f90 b/base/tools/psb_sasb.f90 index ebc675aa6..b0aa03a50 100644 --- a/base/tools/psb_sasb.f90 +++ b/base/tools/psb_sasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - real, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_sasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_sasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_sgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_sasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - real, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_sasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_sasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - real(psb_spk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_sgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sasbv - - subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_sasb_vect implicit none @@ -266,7 +54,7 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -274,7 +62,6 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_sgeasb_v' ictxt = desc_a%get_context() @@ -340,7 +127,7 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me, i, n - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -348,7 +135,6 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_sgeasb_v' ictxt = desc_a%get_context() @@ -423,7 +209,7 @@ subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -432,7 +218,6 @@ subroutine psb_sasb_multivect(x, desc_a, info, mold, scratch,n) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_sgeasb' ictxt = desc_a%get_context() diff --git a/base/tools/psb_sasb_a.f90 b/base/tools/psb_sasb_a.f90 new file mode 100644 index 000000000..bef96be7d --- /dev/null +++ b/base/tools/psb_sasb_a.f90 @@ -0,0 +1,259 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_sasb.f90 +! +! Subroutine: psb_sasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - real, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_sasb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_sasb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_sgeasb_m' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sasb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_sasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - real, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sasbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_sasbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + real(psb_spk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'psb_sgeasb_v' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sasbv diff --git a/base/tools/psb_scdbldext.F90 b/base/tools/psb_scdbldext.F90 index d4dd77c26..e02f4bf66 100644 --- a/base/tools/psb_scdbldext.F90 +++ b/base/tools/psb_scdbldext.F90 @@ -84,18 +84,20 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) integer(psb_ipk_) :: i, j, err_act,m,& & lovr, lworks,lworkr, n_row,n_col, n_col_prev, & & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo - integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,& + integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e, & & idx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ - integer(psb_mpik_) :: icomm, ictxt, me, np, minfo + integer(psb_lpk_) :: gidx, lnz + integer(psb_mpk_) :: icomm, ictxt, me, np, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) - integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),works(:),workr(:),& + integer(psb_lpk_), allocatable :: works(:),workr(:) + integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),& & t_halo_in(:), t_halo_out(:),temp(:),maskr(:) - integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) + integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -262,13 +264,13 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - orig_ovr(cntov_o)=proc - orig_ovr(cntov_o+1)=1 - orig_ovr(cntov_o+2)=idx - orig_ovr(cntov_o+3)=-1 + orig_ovr(cntov_o) = proc + orig_ovr(cntov_o+1) = 1 + orig_ovr(cntov_o+2) = idx + orig_ovr(cntov_o+3) = -1 cntov_o=cntov_o+3 end Do - counter=counter+n_elem_recv+n_elem_send+3 + counter = counter+n_elem_recv+n_elem_send+3 end Do @@ -319,16 +321,16 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) n_col_prev = desc_ov%get_local_cols() Do While (halo(counter) /= -1) - tot_elem=0 - proc=halo(counter+psb_proc_id_) - n_elem_recv=halo(counter+psb_n_elem_recv_) - n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) + tot_elem = 0 + proc = halo(counter+psb_proc_id_) + n_elem_recv = halo(counter+psb_n_elem_recv_) + n_elem_send = halo(counter+n_elem_recv+psb_n_elem_send_) If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then info = -1 call psb_errpush(info,name) goto 9999 end If - tot_recv=tot_recv+n_elem_recv + tot_recv = tot_recv+n_elem_recv if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ': tot_recv:',proc,n_elem_recv,tot_recv @@ -407,6 +409,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! If (i_ovr <= (novr)) Then call a%csget(idx,idx,n_elem,irow,icol,info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='csget') @@ -431,8 +434,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) if (i_ovr <= novr) then if (tot_elem > 1) then - call psb_msort_unique(works(idxs+1:idxs+tot_elem),i) - tot_elem=i + call psb_msort_unique(works(idxs+1:idxs+tot_elem),lnz) + tot_elem = lnz endif sdsz(proc+1) = tot_elem @@ -451,8 +454,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) ! accumulated RECV requests, we have an all-to-all to build ! matchings SENDs. ! - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, & - & psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,rvsz,1, & + & psb_mpi_mpk_,icomm,minfo) if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') @@ -487,8 +490,8 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) lworkr = max(iszr,1) end if - call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_ipk_integer,& - & workr,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_lpk_,& + & workr,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') @@ -514,12 +517,13 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) j = 0 do i=1,iszr if (maskr(i) < 0) then - j=j+1 + j = j+1 works(j) = workr(i) end if end do ! Eliminate duplicates from request - call psb_msort_unique(works(1:j),iszs) + call psb_msort_unique(works(1:j),lnz) + iszs = lnz ! ! fnd_owner on desc_a because we want the procs who @@ -536,9 +540,9 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) & ': Done fnd_owner', desc_ov%indxmap%get_state() do i=1,iszs - idx = works(i) - n_col = desc_ov%get_local_cols() - call desc_ov%indxmap%g2l_ins(idx,lidx,info) + gidx = works(i) + n_col = desc_ov%get_local_cols() + call desc_ov%indxmap%g2l_ins(gidx,lidx,info) if (desc_ov%get_local_cols() > n_col ) then ! ! This is a new index. Assigning a local index as @@ -640,7 +644,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 end if orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) - cntov_o = cntov_o+counter_o-1 + cntov_o = cntov_o+counter_o-1 orig_ovr(cntov_o:) = -1 call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) deallocate(tmp_ovr_idx,stat=info) diff --git a/base/tools/psb_sfree.f90 b/base/tools/psb_sfree.f90 index d0419aa41..34f03caec 100644 --- a/base/tools/psb_sfree.f90 +++ b/base/tools/psb_sfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - real, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_sfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_sfree - implicit none - - !....parameters... - real(psb_spk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_sfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sfree - - - -! Subroutine: psb_sfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - real, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_sfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_sfreev - implicit none - !....parameters... - real(psb_spk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_sfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sfreev - subroutine psb_sfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_sfree_vect implicit none diff --git a/base/tools/psb_sfree_a.f90 b/base/tools/psb_sfree_a.f90 new file mode 100644 index 000000000..6d7412d0e --- /dev/null +++ b/base/tools/psb_sfree_a.f90 @@ -0,0 +1,164 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_sfree.f90 +! +! Subroutine: psb_sfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_sfree + implicit none + + !....parameters... + real(psb_spk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_sfree' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sfree + + + +! Subroutine: psb_sfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - real, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_sfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_sfreev + implicit none + !....parameters... + real(psb_spk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_sfreev' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sfreev diff --git a/base/tools/psb_sins.f90 b/base/tools/psb_sins.f90 index f6342a041..958033198 100644 --- a/base/tools/psb_sins.f90 +++ b/base/tools/psb_sins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_sinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_spk_), intent(in) :: val(:) - real(psb_spk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_sinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sinsvi - - subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_sins_vect use psi_mod @@ -189,7 +56,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_spk_), intent(in) :: val(:) type(psb_s_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -198,9 +65,9 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -228,15 +95,11 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -303,7 +166,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_s_vect_type), intent(inout) :: val type(psb_s_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -312,9 +175,9 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) real(psb_spk_), allocatable :: lval(:) logical :: local_ @@ -343,15 +206,11 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -379,15 +238,14 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local) local_ = .false. endif + if (irw%is_dev()) call irw%sync() if (local_) then - call x%ins(m,irw,val,dupl_,info) + irl(1:m) = irw%v%v(1:m) else - irl = irw%get_vect() - lval = val%get_vect() - call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.) - call x%ins(m,irl,lval,dupl_,info) - + call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if + + call x%ins(m,irl,lval,dupl_,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -413,7 +271,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_spk_), intent(in) :: val(:,:) type(psb_s_vect_type), intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a @@ -422,9 +280,9 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5), n - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols, n + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -457,15 +315,11 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x(1)%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -523,197 +377,6 @@ end subroutine psb_sins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_sinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - real The source dense submatrix. -! x(:,:) - real The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_sinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - real(psb_spk_), intent(in) :: val(:,:) - real(psb_spk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_sinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_sinsi - - - subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_sins_multivect use psi_mod @@ -725,7 +388,7 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) real(psb_spk_), intent(in) :: val(:,:) type(psb_s_multivect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -734,9 +397,9 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -764,15 +427,11 @@ subroutine psb_sins_multivect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif diff --git a/base/tools/psb_sins_a.f90 b/base/tools/psb_sins_a.f90 new file mode 100644 index 000000000..51bd0bbd1 --- /dev/null +++ b/base/tools/psb_sins_a.f90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psb_sinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - real The source dense submatrix. +! x(:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_sinsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:) + real(psb_spk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_sinsvi' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sinsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_sinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - real The source dense submatrix. +! x(:,:) - real The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_sinsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + real(psb_spk_), intent(in) :: val(:,:) + real(psb_spk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_sinsi' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_sinsi + diff --git a/base/tools/psb_sspalloc.f90 b/base/tools/psb_sspalloc.f90 index 911815267..4b092e62f 100644 --- a/base/tools/psb_sspalloc.f90 +++ b/base/tools/psb_sspalloc.f90 @@ -52,16 +52,17 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) integer(psb_ipk_), optional, intent(in) :: nnz !locals - integer(psb_ipk_) :: ictxt, dectype - integer(psb_ipk_) :: np,me,loc_row,loc_col,& - & length_ia1,length_ia2, err_act,m,n - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ictxt, np, me, err_act + integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype + integer(psb_lpk_) :: m, n integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if name = 'psb_sspall' debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -87,26 +88,23 @@ subroutine psb_sspalloc(a, desc_a, info, nnz) if (present(nnz))then if (nnz < 0) then info=45 - int_err(1)=7 - int_err(2)=nnz - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/7_psb_ipk_,nnz/)) goto 9999 endif - length_ia1=nnz - length_ia2=nnz + nnz_ = nnz else - length_ia1=max(1,5*loc_row) + nnz_ = max(1,5*loc_row) endif if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1 + & write(debug_unit,*) me,' ',trim(name), & + & ':allocating size:',loc_row,loc_col,nnz_ call a%free() !....allocate aspk, ia1, ia2..... - call a%csall(loc_row,loc_col,info,nz=length_ia1) + call a%csall(loc_row,loc_col,info,nz=nnz_) if(info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='sp_all' - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,a_err='sp_all') goto 9999 end if diff --git a/base/tools/psb_sspasb.f90 b/base/tools/psb_sspasb.f90 index 00ef0db96..58241a922 100644 --- a/base/tools/psb_sspasb.f90 +++ b/base/tools/psb_sspasb.f90 @@ -62,15 +62,12 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold) character(len=*), optional, intent(in) :: afmt class(psb_s_base_sparse_mat), intent(in), optional :: mold !....Locals.... - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: np,me,n_col, err_act - integer(psb_ipk_) :: spstate - integer(psb_ipk_) :: ictxt,n_row + integer(psb_ipk_) :: ictxt,np,me, err_act + integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err info = psb_success_ - int_err(1)=0 name = 'psb_spasb' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() diff --git a/base/tools/psb_sspfree.f90 b/base/tools/psb_sspfree.f90 index 3c0266231..aa4cea769 100644 --- a/base/tools/psb_sspfree.f90 +++ b/base/tools/psb_sspfree.f90 @@ -51,10 +51,12 @@ subroutine psb_sspfree(a, desc_a,info) integer(psb_ipk_) :: ictxt, err_act character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_sspfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (.not.psb_is_ok_desc(desc_a)) then info = psb_err_forgot_spall_ diff --git a/base/tools/psb_ssphalo.F90 b/base/tools/psb_ssphalo.F90 index bb6585d52..8534a8387 100644 --- a/base/tools/psb_ssphalo.F90 +++ b/base/tools/psb_ssphalo.F90 @@ -75,15 +75,22 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: np,me,counter,proc,i, & - & n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,& + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: counter,proc,i, & + & n_el_send,k,n_el_recv,idx, r, tot_elem,& & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & irmin,icmin,irmax,icmax,data_,ngtz,totxch,nxs, nxr,& & l1, err_act - integer(psb_mpik_) :: icomm, minfo - integer(psb_mpik_), allocatable :: brvindx(:), & + integer(psb_mpk_) :: icomm, minfo + integer(psb_mpk_), allocatable :: brvindx(:), & & rvsz(:), bsdindx(:),sdsz(:) +#if defined(IPK4) && defined(LPK8) + ! If globals are 8 bytes but locals are 4, things get tricky + integer(psb_ipk_), allocatable :: liasnd(:), ljasnd(:) + integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:), iarcv(:), jarcv(:) +#else integer(psb_ipk_), allocatable :: iasnd(:), jasnd(:) +#endif real(psb_spk_), allocatable :: valsnd(:) type(psb_s_coo_sparse_mat), allocatable :: acoo integer(psb_ipk_), pointer :: idxv(:) @@ -94,10 +101,12 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err - if(psb_get_errstatus() /= 0) return info=psb_success_ name='psb_ssphalo' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -152,6 +161,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& If (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + select case(data_) case(psb_comm_halo_,psb_comm_ext_ ) ! Do not accept OVRLAP_INDEX any longer. @@ -172,7 +182,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& idxs = 0 idxr = 0 - call acoo%allocate(izero,a%get_ncols(),info) + call acoo%allocate(izero,a%get_ncols()) call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info) @@ -195,8 +205,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& counter = counter+n_el_send+3 Enddo - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& - & rvsz,1,psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') @@ -225,14 +235,417 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_reall') - goto 9999 - end if mat_recv = iszr iszs=sum(sdsz) - call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) +#if defined(IPK4) && defined(LPK8) + ! If globals are 8 bytes but locals are not, things get tricky + if (info == psb_success_) call psb_ensure_size(max(iszs,1),liasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),ljasnd,info) + + if (info == psb_success_) call psb_ensure_size(max(iszr,1),iarcv,info) + if (info == psb_success_) call psb_ensure_size(max(iszr,1),jarcv,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv=ipdxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=ipdxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + call a%csget(idx,idx,ngtz,liasnd,ljasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + ipx = ipx + 1 + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) then + call psb_loc_to_glob(liasnd(1:nz),iasnd(1:nz),desc_a,info,iact='I') + else + iasnd(1:nz) = liasnd(1:nz) + end if + if (colcnv_) then + call psb_loc_to_glob(ljasnd(1:nz),jasnd(1:nz),desc_a,info,iact='I') + else + jasnd(1:nz) = ljasnd(1:nz) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& + & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & iarcv,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & jarcv,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) then + call psb_glob_to_loc(iarcv(1:iszr),acoo%ia(1:iszr),desc_a,info,iact='I') + else + acoo%ia(1:iszr) = iarcv(1:iszr) + end if + if (colcnv_) then + call psb_glob_to_loc(jarcv(1:iszr),acoo%ja(1:iszr),desc_a,info,iact='I') + else + acoo%ja(1:iszr) = jarcv(1:iszr) + end if + +#else + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv=ipdxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=ipdxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + ipx = ipx + 1 + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') + if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& + & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_,& + & acoo%ia,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_,& + & acoo%ja,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') + if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') +#endif + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psbglob_to_loc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + l1 = 0 + call acoo%set_nrows(izero) + ! + irmin = huge(irmin) + icmin = huge(icmin) + irmax = 0 + icmax = 0 + Do i=1,iszr + r=(acoo%ia(i)) + k=(acoo%ja(i)) + ! Just in case some of the conversions were out-of-range + If ((r>0).and.(k>0)) Then + l1=l1+1 + acoo%val(l1) = acoo%val(i) + acoo%ia(l1) = r + acoo%ja(l1) = k + irmin = min(irmin,r) + irmax = max(irmax,r) + icmin = min(icmin,k) + icmax = max(icmax,k) + End If + Enddo + if (rowscale_) then + call acoo%set_nrows(max(irmax-irmin+1,0)) + acoo%ia(1:l1) = acoo%ia(1:l1) - irmin + 1 + else + call acoo%set_nrows(irmax) + end if + if (colscale_) then + call acoo%set_ncols(max(icmax-icmin+1,0)) + acoo%ja(1:l1) = acoo%ja(1:l1) - icmin + 1 + else + call acoo%set_ncols(icmax) + end if + + call acoo%set_nzeros(l1) + call acoo%set_sorted(.false.) + + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': End data exchange',counter,l1 + + call move_alloc(acoo,blk%a) + + ! Do we expect any duplicates to appear???? + call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spcnv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Deallocate(brvindx,bsdindx,rvsz,sdsz,& + & iasnd,jasnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +End Subroutine psb_ssphalo + + +Subroutine psb_lssphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + use psb_base_mod, psb_protect_name => psb_lssphalo + +#ifdef MPI_MOD + use mpi +#endif + Implicit None +#ifdef MPI_H + include 'mpif.h' +#endif + + Type(psb_lsspmat_type),Intent(in) :: a + Type(psb_lsspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer(psb_ipk_), intent(in), optional :: data + ! ...local scalars.... + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: counter, proc, i, & + & n_el_send,n_el_recv,& + & n_elem, j, ipx,mat_recv, idxs,idxr,nz,& + & data_,totxch,nxs, nxr + integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, & + & lidx, l1, lnr, lnc, idx, ngtz, tot_elem + integer(psb_mpk_) :: icomm, minfo + integer(psb_mpk_), allocatable :: brvindx(:), & + & rvsz(:), bsdindx(:),sdsz(:) + integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) + real(psb_spk_), allocatable :: valsnd(:) + type(psb_ls_coo_sparse_mat), allocatable :: acoo + integer(psb_ipk_), pointer :: idxv(:) + class(psb_i_base_vect_type), pointer :: pdxv + integer(psb_ipk_), allocatable :: ipdxv(:) + logical :: rowcnv_,colcnv_,rowscale_,colscale_ + character(len=5) :: outfmt_ + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_ssphalo' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + Call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Start' + + if (present(rowcnv)) then + rowcnv_ = rowcnv + else + rowcnv_ = .true. + endif + if (present(colcnv)) then + colcnv_ = colcnv + else + colcnv_ = .true. + endif + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .false. + endif + if (present(colscale)) then + colscale_ = colscale + else + colscale_ = .false. + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + if (present(outfmt)) then + outfmt_ = psb_toupper(outfmt) + else + outfmt_ = 'CSR' + endif + + Allocate(brvindx(np+1),& + & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + If (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + + select case(data_) + case(psb_comm_halo_,psb_comm_ext_ ) + ! Do not accept OVRLAP_INDEX any longer. + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector') + goto 9999 + end select + + + sdsz(:)=0 + rvsz(:)=0 + l1 = 0 + ipx = 1 + brvindx(ipx) = 0 + bsdindx(ipx) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + lnc = a%get_ncols() + call acoo%allocate(lzero,lnc) + + + call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info) + ipdxv = pdxv%get_vect() + ! For all rows in the halo descriptor, extract and send/receive. + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv = ipdxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = ipdxv(counter+psb_n_elem_send_) + tot_elem = 0 + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + tot_elem = tot_elem+n_elem + Enddo + sdsz(proc+1) = tot_elem + call acoo%set_nrows(acoo%get_nrows() + n_el_recv) + counter = counter+n_el_send+3 + Enddo + + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv = ipdxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = ipdxv(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_el_send+3 + Enddo + + iszr=sum(rvsz) + call acoo%reallocate(max(iszr,1)) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& + & ' Send:',sdsz(:),' Receive:',rvsz(:) + mat_recv = iszr + iszs=sum(sdsz) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) if (info /= psb_success_) then @@ -241,6 +654,11 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& goto 9999 end if + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + l1 = 0 ipx = 1 counter=1 @@ -282,10 +700,10 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_r_spk_,& & acoo%val,rvsz,brvindx,psb_mpi_r_spk_,icomm,minfo) - call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& - & acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) - call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& - & acoo%ja,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') @@ -297,7 +715,6 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') - if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psbglob_to_loc') @@ -305,7 +722,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& end if l1 = 0 - call acoo%set_nrows(izero) + call acoo%set_nrows(lzero) ! irmin = huge(irmin) icmin = huge(icmin) @@ -368,4 +785,4 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,& return -End Subroutine psb_ssphalo +End Subroutine psb_lssphalo diff --git a/base/tools/psb_sspins.f90 b/base/tools/psb_sspins.f90 index 35058f523..eaab4601e 100644 --- a/base/tools/psb_sspins.f90 +++ b/base/tools/psb_sspins.f90 @@ -56,10 +56,11 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !....parameters... type(psb_desc_type), intent(inout) :: desc_a type(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: rebuild, local + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: rebuild, local !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate @@ -68,7 +69,6 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -122,9 +122,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if @@ -133,9 +132,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & mask=(ila(1:nz)>0)) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if nrow = desc_a%get_local_rows() @@ -159,31 +157,24 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() + allocate(ila(nz),jla(nz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate',i_err=(/info/)) + goto 9999 + end if if (local_) then - call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + ila(1:nz) = ia(1:nz) + jla(1:nz) = ja(1:nz) else - allocate(ila(nz),jla(nz),stat=info) - if (info /= psb_success_) then - ierr(1) = info - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) - goto 9999 - end if - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info) if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info) - - call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + end if + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 end if else info = psb_err_invalid_cd_state_ @@ -210,9 +201,10 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) type(psb_desc_type), intent(in) :: desc_ar type(psb_desc_type), intent(inout) :: desc_ac type(psb_sspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) real(psb_spk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate @@ -220,7 +212,6 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -268,9 +259,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if @@ -279,9 +269,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) & mask=(ila(1:nz)>0)) if (psb_errstatus_fatal()) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if @@ -327,7 +316,7 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) type(psb_desc_type), intent(inout) :: desc_a type(psb_sspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz - type(psb_i_vect_type), intent(inout) :: ia,ja + type(psb_l_vect_type), intent(inout) :: ia,ja type(psb_s_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild, local @@ -340,7 +329,6 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -394,9 +382,8 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) else allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if if (ia%is_dev()) call ia%sync() @@ -407,9 +394,8 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) call desc_a%indxmap%g2l_ins(ja%v%v(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0)) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if nrow = desc_a%get_local_rows() @@ -433,33 +419,28 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() + allocate(ila(nz),jla(nz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate',i_err=(/info/)) + goto 9999 + end if + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + if (val%is_dev()) call val%sync() + if (local_) then - call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + ila(1:nz) = ia%v%v(1:nz) + jla(1:nz) = ja%v%v(1:nz) else - allocate(ila(nz),jla(nz),stat=info) - if (info /= psb_success_) then - ierr(1) = info - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) - goto 9999 - end if - if (ia%is_dev()) call ia%sync() - if (ja%is_dev()) call ja%sync() - if (val%is_dev()) call val%sync() - call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info) if (info == 0) call desc_a%indxmap%g2l(ja%v%v(1:nz),jla(1:nz),info) - if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + end if + if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 end if else info = psb_err_invalid_cd_state_ diff --git a/base/tools/psb_ssprn.f90 b/base/tools/psb_ssprn.f90 index 5b666286c..3a7500335 100644 --- a/base/tools/psb_ssprn.f90 +++ b/base/tools/psb_ssprn.f90 @@ -53,15 +53,12 @@ Subroutine psb_ssprn(a, desc_a,info,clear) logical, intent(in), optional :: clear !locals - integer(psb_ipk_) :: ictxt,np,me,err,err_act + integer(psb_ipk_) :: ictxt,np,me,err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: int_err(5) character(len=20) :: name logical :: clear_ info = psb_success_ - err = 0 - int_err(1)=0 name = 'psb_ssprn' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() diff --git a/base/tools/psb_z_map.f90 b/base/tools/psb_z_map.f90 index d58c4a82d..53893f85e 100644 --- a/base/tools/psb_z_map.f90 +++ b/base/tools/psb_z_map.f90 @@ -401,7 +401,7 @@ function psb_z_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) & type(psb_desc_type), target :: desc_X, desc_Y type(psb_zspmat_type), intent(inout) :: map_X2Y, map_Y2X integer(psb_ipk_), intent(in) :: map_kind - integer(psb_ipk_), intent(in), optional :: iaggr(:), naggr(:) + integer(psb_lpk_), intent(in), optional :: iaggr(:), naggr(:) ! integer(psb_ipk_) :: info character(len=20), parameter :: name='psb_linmap' diff --git a/base/tools/psb_zallc.f90 b/base/tools/psb_zallc.f90 index e5417decf..e01f0af2e 100644 --- a/base/tools/psb_zallc.f90 +++ b/base/tools/psb_zallc.f90 @@ -42,209 +42,6 @@ ! info - Return code ! n - optional number of columns. ! lb - optional lower bound on column indices -subroutine psb_zalloc(x, desc_a, info, n, lb) - use psb_base_mod, psb_protect_name => psb_zalloc - use psi_mod - implicit none - - !....parameters... - complex(psb_dpk_), allocatable, intent(out) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n, lb - - !locals - integer(psb_ipk_) :: np,me,err,nr,i,j,err_act - integer(psb_ipk_) :: ictxt,n_ - integer(psb_ipk_) :: int_err(5),exch(3) - character(len=20) :: name - - name='psb_geall' - if(psb_get_errstatus() /= 0) return - info=psb_success_ - err=0 - int_err(1)=0 - call psb_erractionsave(err_act) - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(n)) then - n_ = n - else - n_ = 1 - endif - !global check on n parameters - if (me == psb_root_) then - exch(1)=n_ - call psb_bcast(ictxt,exch(1),root=psb_root_) - else - call psb_bcast(ictxt,exch(1),root=psb_root_) - if (exch(1) /= n_) then - info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,n_,x,info,lb2=lb) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr*n_ - call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)') - goto 9999 - endif - - x(:,:) = zzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zalloc - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! Function: psb_zallocv -! Allocates dense matrix for PSBLAS routines -! The descriptor may be in either the build or assembled state. -! -! Arguments: -! x(:) - the matrix to be allocated. -! desc_a - the communication descriptor. -! info - return code -subroutine psb_zallocv(x, desc_a,info,n) - use psb_base_mod, psb_protect_name => psb_zallocv - use psi_mod - implicit none - - !....parameters... - complex(psb_dpk_), allocatable, intent(out) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_),intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: n - - !locals - integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) - integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_geall' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check m and n parameters.... - if (.not.psb_is_ok_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! As this is a rank-1 array, optional parameter N is actually ignored. - - !....allocate x ..... - if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then - nr = max(1,desc_a%get_local_cols()) - else if (psb_is_bld_desc(desc_a)) then - nr = max(1,desc_a%get_local_rows()) - else - info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') - goto 9999 - endif - - call psb_realloc(nr,x,info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)') - goto 9999 - endif - - x(:) = zzero - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zallocv - - subroutine psb_zalloc_vect(x, desc_a,info,n) use psb_base_mod, psb_protect_name => psb_zalloc_vect use psi_mod @@ -258,7 +55,7 @@ subroutine psb_zalloc_vect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act - integer(psb_ipk_) :: ictxt, int_err(5) + integer(psb_ipk_) :: ictxt integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -295,7 +92,7 @@ subroutine psb_zalloc_vect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -303,8 +100,7 @@ subroutine psb_zalloc_vect(x, desc_a,info,n) if (info == 0) call x%all(nr,info) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif call x%zero() @@ -331,7 +127,7 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -378,8 +174,7 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -392,7 +187,7 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -407,8 +202,7 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb) end if if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif @@ -435,7 +229,7 @@ subroutine psb_zalloc_multivect(x, desc_a,info,n) !locals integer(psb_ipk_) :: np,me,nr,i,err_act, n_, lb_ - integer(psb_ipk_) :: ictxt, int_err(5), exch(1) + integer(psb_ipk_) :: ictxt, exch(1) integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name @@ -477,8 +271,7 @@ subroutine psb_zalloc_multivect(x, desc_a,info,n) call psb_bcast(ictxt,exch(1),root=psb_root_) if (exch(1) /= n_) then info=psb_err_parm_differs_among_procs_ - int_err(1)=1 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione/)) goto 9999 endif endif @@ -491,7 +284,7 @@ subroutine psb_zalloc_multivect(x, desc_a,info,n) nr = max(1,desc_a%get_local_rows()) else info = psb_err_internal_error_ - call psb_errpush(info,name,int_err,a_err='Invalid desc_a') + call psb_errpush(info,name,a_err='Invalid desc_a') goto 9999 endif @@ -501,8 +294,7 @@ subroutine psb_zalloc_multivect(x, desc_a,info,n) if (psb_errstatus_fatal()) then info=psb_err_alloc_request_ - int_err(1)=nr - call psb_errpush(info,name,int_err,a_err='real(psb_spk_)') + call psb_errpush(info,name,i_err=(/nr/),a_err='real(psb_spk_)') goto 9999 endif diff --git a/base/tools/psb_zallc_a.f90 b/base/tools/psb_zallc_a.f90 new file mode 100644 index 000000000..9fa7993c6 --- /dev/null +++ b/base/tools/psb_zallc_a.f90 @@ -0,0 +1,246 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! +! File: psb_zallc.f90 +! +! Function: psb_zalloc +! Allocates dense matrix for PSBLAS routines. +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - Return code +! n - optional number of columns. +! lb - optional lower bound on column indices +subroutine psb_zalloc(x, desc_a, info, n, lb) + use psb_base_mod, psb_protect_name => psb_zalloc + use psi_mod + implicit none + + !....parameters... + complex(psb_dpk_), allocatable, intent(out) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n, lb + + !locals + integer(psb_ipk_) :: err,nr,i,j,n_,err_act + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: exch(3) + character(len=20) :: name + + name='psb_geall' + info = psb_success_ + err = 0 + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(n)) then + n_ = n + else + n_ = 1 + endif + !global check on n parameters + if (me == psb_root_) then + exch(1)=n_ + call psb_bcast(ictxt,exch(1),root=psb_root_) + else + call psb_bcast(ictxt,exch(1),root=psb_root_) + if (exch(1) /= n_) then + info=psb_err_parm_differs_among_procs_ + call psb_errpush(info,name,i_err=(/ione/)) + goto 9999 + endif + endif + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,n_,x,info,lb2=lb) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr*n_/),a_err='complex(psb_dpk_)') + goto 9999 + endif + + x(:,:) = zzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zalloc + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! +! Function: psb_zallocv +! Allocates dense matrix for PSBLAS routines +! The descriptor may be in either the build or assembled state. +! +! Arguments: +! x(:) - the matrix to be allocated. +! desc_a - the communication descriptor. +! info - return code +subroutine psb_zallocv(x, desc_a,info,n) + use psb_base_mod, psb_protect_name => psb_zallocv + use psi_mod + implicit none + + !....parameters... + complex(psb_dpk_), allocatable, intent(out) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_),intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: n + + !locals + integer(psb_ipk_) :: nr,i,err_act + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: debug_level, debug_unit + character(len=20) :: name + + info=psb_success_ + name='psb_geall' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check m and n parameters.... + if (.not.psb_is_ok_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! As this is a rank-1 array, optional parameter N is actually ignored. + + !....allocate x ..... + if (psb_is_asb_desc(desc_a).or.psb_is_upd_desc(desc_a)) then + nr = max(1,desc_a%get_local_cols()) + else if (psb_is_bld_desc(desc_a)) then + nr = max(1,desc_a%get_local_rows()) + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid desc_a') + goto 9999 + endif + + call psb_realloc(nr,x,info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/nr/),a_err='complex(psb_dpk_)') + goto 9999 + endif + + x(:) = zzero + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zallocv + diff --git a/base/tools/psb_zasb.f90 b/base/tools/psb_zasb.f90 index 1e640bddf..5d6127c91 100644 --- a/base/tools/psb_zasb.f90 +++ b/base/tools/psb_zasb.f90 @@ -42,218 +42,6 @@ ! x(:,:) - complex, allocatable The matrix to be assembled. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. return code -subroutine psb_zasb(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_zasb - implicit none - - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act - integer(psb_ipk_) :: i1sz, i2sz - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name, ch_err - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - name='psb_zgeasb_m' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - ictxt = desc_a%get_context() - - call psb_info(ictxt, me, np) - - - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': start: ',np,& - & desc_a%get_dectype() - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),' error ' - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - ! check size - ictxt = desc_a%get_context() - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol - - if (i1sz < ncol) then - call psb_realloc(ncol,i2sz,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='psb_halo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zasb - - -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_zasb -! Assembles a dense matrix for PSBLAS routines -! Since the allocation may have been called with the desciptor -! in the build state we make sure that X has a number of rows -! allowing for the halo indices, reallocating if necessary. -! We also call the halo routine for good measure. -! -! Arguments: -! x(:) - complex, allocatable The matrix to be assembled. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_zasbv(x, desc_a, info, scratch) - use psb_base_mod, psb_protect_name => psb_zasbv - implicit none - - type(psb_desc_type), intent(in) :: desc_a - complex(psb_dpk_), allocatable, intent(inout) :: x(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: scratch - - ! local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act - integer(psb_ipk_) :: debug_level, debug_unit - logical :: scratch_ - character(len=20) :: name,ch_err - - info = psb_success_ - int_err(1) = 0 - name = 'psb_zgeasb_v' - - ictxt = desc_a%get_context() - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - scratch_ = .false. - if (present(scratch)) scratch_ = scratch - - call psb_info(ictxt, me, np) - - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - else if (.not.psb_is_asb_desc(desc_a)) then - info = psb_err_input_matrix_unassembled_ - call psb_errpush(info,name) - goto 9999 - endif - - nrow = desc_a%get_local_rows() - ncol = desc_a%get_local_cols() - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol - i1sz = size(x) - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol - if (i1sz < ncol) then - call psb_realloc(ncol,x,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_realloc') - goto 9999 - endif - endif - - if (.not.scratch_) then - ! ..update halo elements.. - call psb_halo(x,desc_a,info) - if(info /= psb_success_) then - info=psb_err_from_subroutine_ - ch_err='f90_pshalo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - end if - if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),': end' - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zasbv - - subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) use psb_base_mod, psb_protect_name => psb_zasb_vect implicit none @@ -266,7 +54,7 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -274,7 +62,6 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_zgeasb_v' ictxt = desc_a%get_context() @@ -340,7 +127,7 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) ! local variables integer(psb_ipk_) :: ictxt,np,me, i, n - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name,ch_err @@ -348,7 +135,6 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_zgeasb_v' ictxt = desc_a%get_context() @@ -423,7 +209,7 @@ subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n) ! local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: int_err(5), i1sz,nrow,ncol, err_act, n_ + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act, n_ logical :: scratch_ integer(psb_ipk_) :: debug_level, debug_unit @@ -432,7 +218,6 @@ subroutine psb_zasb_multivect(x, desc_a, info, mold, scratch,n) info = psb_success_ if (psb_errstatus_fatal()) return - int_err(1) = 0 name = 'psb_zgeasb' ictxt = desc_a%get_context() diff --git a/base/tools/psb_zasb_a.f90 b/base/tools/psb_zasb_a.f90 new file mode 100644 index 000000000..0492475a6 --- /dev/null +++ b/base/tools/psb_zasb_a.f90 @@ -0,0 +1,259 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zasb.f90 +! +! Subroutine: psb_zasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:,:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +subroutine psb_zasb(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_zasb + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), allocatable, intent(inout) :: x(:,:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me,nrow,ncol, err_act + integer(psb_ipk_) :: i1sz, i2sz + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_zgeasb_m' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': start: ',np,& + & desc_a%get_dectype() + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),' error ' + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + ! check size + ictxt = desc_a%get_context() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + i1sz = size(x,dim=1) + i2sz = size(x,dim=2) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': ',i1sz,i2sz,nrow,ncol + + if (i1sz < ncol) then + call psb_realloc(ncol,i2sz,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_halo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zasb + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_zasb +! Assembles a dense matrix for PSBLAS routines +! Since the allocation may have been called with the desciptor +! in the build state we make sure that X has a number of rows +! allowing for the halo indices, reallocating if necessary. +! We also call the halo routine for good measure. +! +! Arguments: +! x(:) - complex, allocatable The matrix to be assembled. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_zasbv(x, desc_a, info, scratch) + use psb_base_mod, psb_protect_name => psb_zasbv + implicit none + + type(psb_desc_type), intent(in) :: desc_a + complex(psb_dpk_), allocatable, intent(inout) :: x(:) + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: scratch + + ! local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i1sz,nrow,ncol, err_act + integer(psb_ipk_) :: debug_level, debug_unit + logical :: scratch_ + character(len=20) :: name,ch_err + + info = psb_success_ + name = 'psb_zgeasb_v' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + ictxt = desc_a%get_context() + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + scratch_ = .false. + if (present(scratch)) scratch_ = scratch + + call psb_info(ictxt, me, np) + + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + else if (.not.psb_is_asb_desc(desc_a)) then + info = psb_err_input_matrix_unassembled_ + call psb_errpush(info,name) + goto 9999 + endif + + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes: ',nrow,ncol + i1sz = size(x) + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': sizes ',i1sz,ncol + if (i1sz < ncol) then + call psb_realloc(ncol,x,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='psb_realloc') + goto 9999 + endif + endif + + if (.not.scratch_) then + ! ..update halo elements.. + call psb_halo(x,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='f90_pshalo' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + end if + if (debug_level >= psb_debug_ext_) & + & write(debug_unit,*) me,' ',trim(name),': end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zasbv diff --git a/base/tools/psb_zcdbldext.F90 b/base/tools/psb_zcdbldext.F90 index e967190da..6262b8864 100644 --- a/base/tools/psb_zcdbldext.F90 +++ b/base/tools/psb_zcdbldext.F90 @@ -84,18 +84,20 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) integer(psb_ipk_) :: i, j, err_act,m,& & lovr, lworks,lworkr, n_row,n_col, n_col_prev, & & index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo - integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e,& + integer(psb_ipk_) :: counter,counter_h, counter_o, counter_e, & & idx,proc,n_elem_recv,& & n_elem_send,tot_recv,tot_elem,cntov_o,& & counter_t,n_elem,i_ovr,jj,proc_id,isz, & & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ - integer(psb_mpik_) :: icomm, ictxt, me, np, minfo + integer(psb_lpk_) :: gidx, lnz + integer(psb_mpk_) :: icomm, ictxt, me, np, minfo integer(psb_ipk_), allocatable :: irow(:), icol(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) - integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),works(:),workr(:),& + integer(psb_lpk_), allocatable :: works(:),workr(:) + integer(psb_ipk_), allocatable :: halo(:),ovrlap(:),& & t_halo_in(:), t_halo_out(:),temp(:),maskr(:) - integer(psb_mpik_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) + integer(psb_mpk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: ierr(5) character(len=20) :: name, ch_err @@ -262,13 +264,13 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) call psb_errpush(info,name,a_err='psb_ensure_size') goto 9999 end if - orig_ovr(cntov_o)=proc - orig_ovr(cntov_o+1)=1 - orig_ovr(cntov_o+2)=idx - orig_ovr(cntov_o+3)=-1 + orig_ovr(cntov_o) = proc + orig_ovr(cntov_o+1) = 1 + orig_ovr(cntov_o+2) = idx + orig_ovr(cntov_o+3) = -1 cntov_o=cntov_o+3 end Do - counter=counter+n_elem_recv+n_elem_send+3 + counter = counter+n_elem_recv+n_elem_send+3 end Do @@ -319,16 +321,16 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) n_col_prev = desc_ov%get_local_cols() Do While (halo(counter) /= -1) - tot_elem=0 - proc=halo(counter+psb_proc_id_) - n_elem_recv=halo(counter+psb_n_elem_recv_) - n_elem_send=halo(counter+n_elem_recv+psb_n_elem_send_) + tot_elem = 0 + proc = halo(counter+psb_proc_id_) + n_elem_recv = halo(counter+psb_n_elem_recv_) + n_elem_send = halo(counter+n_elem_recv+psb_n_elem_send_) If ((counter+n_elem_recv+n_elem_send) > Size(halo)) then info = -1 call psb_errpush(info,name) goto 9999 end If - tot_recv=tot_recv+n_elem_recv + tot_recv = tot_recv+n_elem_recv if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ': tot_recv:',proc,n_elem_recv,tot_recv @@ -407,6 +409,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! If (i_ovr <= (novr)) Then call a%csget(idx,idx,n_elem,irow,icol,info) + if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='csget') @@ -431,8 +434,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) if (i_ovr <= novr) then if (tot_elem > 1) then - call psb_msort_unique(works(idxs+1:idxs+tot_elem),i) - tot_elem=i + call psb_msort_unique(works(idxs+1:idxs+tot_elem),lnz) + tot_elem = lnz endif sdsz(proc+1) = tot_elem @@ -451,8 +454,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) ! accumulated RECV requests, we have an all-to-all to build ! matchings SENDs. ! - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,rvsz,1, & - & psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,rvsz,1, & + & psb_mpi_mpk_,icomm,minfo) if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') @@ -487,8 +490,8 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) lworkr = max(iszr,1) end if - call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_ipk_integer,& - & workr,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(works,sdsz,bsdindx,psb_mpi_lpk_,& + & workr,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (minfo /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') @@ -514,12 +517,13 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) j = 0 do i=1,iszr if (maskr(i) < 0) then - j=j+1 + j = j+1 works(j) = workr(i) end if end do ! Eliminate duplicates from request - call psb_msort_unique(works(1:j),iszs) + call psb_msort_unique(works(1:j),lnz) + iszs = lnz ! ! fnd_owner on desc_a because we want the procs who @@ -536,9 +540,9 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) & ': Done fnd_owner', desc_ov%indxmap%get_state() do i=1,iszs - idx = works(i) - n_col = desc_ov%get_local_cols() - call desc_ov%indxmap%g2l_ins(idx,lidx,info) + gidx = works(i) + n_col = desc_ov%get_local_cols() + call desc_ov%indxmap%g2l_ins(gidx,lidx,info) if (desc_ov%get_local_cols() > n_col ) then ! ! This is a new index. Assigning a local index as @@ -640,7 +644,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype) goto 9999 end if orig_ovr(cntov_o:cntov_o+counter_o-1) = tmp_ovr_idx(1:counter_o) - cntov_o = cntov_o+counter_o-1 + cntov_o = cntov_o+counter_o-1 orig_ovr(cntov_o:) = -1 call psb_move_alloc(orig_ovr,desc_ov%ovrlap_index,info) deallocate(tmp_ovr_idx,stat=info) diff --git a/base/tools/psb_zfree.f90 b/base/tools/psb_zfree.f90 index ad2a02070..cdb9d0470 100644 --- a/base/tools/psb_zfree.f90 +++ b/base/tools/psb_zfree.f90 @@ -38,129 +38,6 @@ ! x(:,:) - complex, allocatable The dense matrix to be freed. ! desc_a - type(psb_desc_type). The communication descriptor. ! info - integer. Return code -subroutine psb_zfree(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_zfree - implicit none - - !....parameters... - complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_zfree' - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - ! ....verify blacs grid correctness.. - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zfree - - - -! Subroutine: psb_zfreev -! frees a dense matrix structure -! -! Arguments: -! x(:) - complex, allocatable The dense matrix to be freed. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. Return code -subroutine psb_zfreev(x, desc_a, info) - use psb_base_mod, psb_protect_name => psb_zfreev - implicit none - !....parameters... - complex(psb_dpk_),allocatable, intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - - !...locals.... - integer(psb_ipk_) :: ictxt,np,me, err_act - character(len=20) :: name - - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name='psb_zfreev' - - - if (.not.psb_is_ok_desc(desc_a)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - - endif - - if (.not.allocated(x)) then - info=psb_err_forgot_spall_ - call psb_errpush(info,name) - goto 9999 - end if - - !deallocate x - deallocate(x,stat=info) - if (info /= psb_no_err_) then - info=psb_err_alloc_dealloc_ - call psb_errpush(info,name) - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zfreev - subroutine psb_zfree_vect(x, desc_a, info) use psb_base_mod, psb_protect_name => psb_zfree_vect implicit none diff --git a/base/tools/psb_zfree_a.f90 b/base/tools/psb_zfree_a.f90 new file mode 100644 index 000000000..7dc6498e6 --- /dev/null +++ b/base/tools/psb_zfree_a.f90 @@ -0,0 +1,164 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_zfree.f90 +! +! Subroutine: psb_zfree +! frees a dense matrix structure +! +! Arguments: +! x(:,:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_zfree(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_zfree + implicit none + + !....parameters... + complex(psb_dpk_),allocatable, intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_zfree' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + ! ....verify blacs grid correctness.. + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zfree + + + +! Subroutine: psb_zfreev +! frees a dense matrix structure +! +! Arguments: +! x(:) - complex, allocatable The dense matrix to be freed. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. Return code +subroutine psb_zfreev(x, desc_a, info) + use psb_base_mod, psb_protect_name => psb_zfreev + implicit none + !....parameters... + complex(psb_dpk_),allocatable, intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + !...locals.... + integer(psb_ipk_) :: ictxt,np,me, err_act + character(len=20) :: name + + name='psb_zfreev' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.psb_is_ok_desc(desc_a)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + + endif + + if (.not.allocated(x)) then + info=psb_err_forgot_spall_ + call psb_errpush(info,name) + goto 9999 + end if + + !deallocate x + deallocate(x,stat=info) + if (info /= psb_no_err_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zfreev diff --git a/base/tools/psb_zins.f90 b/base/tools/psb_zins.f90 index c03819fe0..e87f3a112 100644 --- a/base/tools/psb_zins.f90 +++ b/base/tools/psb_zins.f90 @@ -45,139 +45,6 @@ ! dupl - integer What to do with duplicates: ! psb_dupl_ovwrt_ overwrite ! psb_dupl_add_ add -subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_zinsvi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_dpk_), intent(in) :: val(:) - complex(psb_dpk_),intent(inout) :: x(:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_zinsvi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - - if (m == 0) return - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = val(i) - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - if (irl(i) > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - x(irl(i)) = x(irl(i)) + val(i) - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zinsvi - - subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_zins_vect use psi_mod @@ -189,7 +56,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_dpk_), intent(in) :: val(:) type(psb_z_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -198,9 +65,9 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_,err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -228,15 +95,11 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -303,7 +166,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - type(psb_i_vect_type), intent(inout) :: irw + type(psb_l_vect_type), intent(inout) :: irw type(psb_z_vect_type), intent(inout) :: val type(psb_z_vect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -312,9 +175,9 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_ integer(psb_ipk_), allocatable :: irl(:) complex(psb_dpk_), allocatable :: lval(:) logical :: local_ @@ -343,15 +206,11 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -379,15 +238,14 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local) local_ = .false. endif + if (irw%is_dev()) call irw%sync() if (local_) then - call x%ins(m,irw,val,dupl_,info) + irl(1:m) = irw%v%v(1:m) else - irl = irw%get_vect() - lval = val%get_vect() - call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.) - call x%ins(m,irl,lval,dupl_,info) - + call desc_a%indxmap%g2l(irw%v%v(1:m),irl(1:m),info,owned=.true.) end if + + call x%ins(m,irl,lval,dupl_,info) if (info /= 0) then call psb_errpush(info,name) goto 9999 @@ -413,7 +271,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_dpk_), intent(in) :: val(:,:) type(psb_z_vect_type), intent(inout) :: x(:) type(psb_desc_type), intent(in) :: desc_a @@ -422,9 +280,9 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5), n - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols, n + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -457,15 +315,11 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x(1)%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif @@ -523,197 +377,6 @@ end subroutine psb_zins_vect_r2 -!!$ -!!$ Parallel Sparse BLAS version 3.5 -!!$ (C) Copyright 2006-2018 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! Subroutine: psb_zinsi -! Insert dense submatrix to dense matrix. Note: the row indices in IRW -! are assumed to be in global numbering and are converted on the fly. -! Row indices not belonging to the current process are silently discarded. -! -! Arguments: -! m - integer. Number of rows of submatrix belonging to -! val to be inserted. -! irw(:) - integer Row indices of rows of val (global numbering) -! val(:,:) - complex The source dense submatrix. -! x(:,:) - complex The destination dense matrix. -! desc_a - type(psb_desc_type). The communication descriptor. -! info - integer. return code -! dupl - integer What to do with duplicates: -! psb_dupl_ovwrt_ overwrite -! psb_dupl_add_ add -subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local) - use psb_base_mod, psb_protect_name => psb_zinsi - use psi_mod - implicit none - - ! m rows number of submatrix belonging to val to be inserted - - ! ix x global-row corresponding to position at which val submatrix - ! must be inserted - - !....parameters... - integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) - complex(psb_dpk_), intent(in) :: val(:,:) - complex(psb_dpk_),intent(inout) :: x(:,:) - type(psb_desc_type), intent(in) :: desc_a - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: dupl - logical, intent(in), optional :: local - - !locals..... - integer(psb_ipk_) :: ictxt,i,loc_row,j,n,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np,me,dupl_ - integer(psb_ipk_), allocatable :: irl(:) - logical :: local_ - character(len=20) :: name - - if(psb_get_errstatus() /= 0) return - info=psb_success_ - call psb_erractionsave(err_act) - name = 'psb_zinsi' - - if (.not.desc_a%is_ok()) then - info = psb_err_invalid_cd_state_ - call psb_errpush(info,name) - return - end if - - ictxt=desc_a%get_context() - - call psb_info(ictxt, me, np) - if (np == -1) then - info = psb_err_context_error_ - call psb_errpush(info,name) - goto 9999 - endif - - !... check parameters.... - if (m < 0) then - info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) - goto 9999 - else if (size(x, dim=1) < desc_a%get_local_rows()) then - info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) - goto 9999 - endif - if (m == 0) return - - loc_rows = desc_a%get_local_rows() - loc_cols = desc_a%get_local_cols() - mglob = desc_a%get_global_rows() - - n = min(size(val,2),size(x,2)) - - if (present(dupl)) then - dupl_ = dupl - else - dupl_ = psb_dupl_ovwrt_ - endif - - allocate(irl(m),stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - endif - if (present(local)) then - local_ = local - else - local_ = .false. - endif - - if (local_) then - irl(1:m) = irw(1:m) - else - call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) - end if - - select case(dupl_) - case(psb_dupl_ovwrt_) - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = val(i,j) - end do - end if - enddo - - case(psb_dupl_add_) - - do i = 1, m - !loop over all val's rows - - ! row actual block row - loc_row = irl(i) - if (loc_row > 0) then - ! this row belongs to me - ! copy i-th row of block val in x - do j=1,n - x(loc_row,j) = x(loc_row,j) + val(i,j) - end do - end if - enddo - - case default - info = 321 - call psb_errpush(info,name) - goto 9999 - end select - deallocate(irl) - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(ictxt,err_act) - - return - -end subroutine psb_zinsi - - - subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) use psb_base_mod, psb_protect_name => psb_zins_multivect use psi_mod @@ -725,7 +388,7 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) !....parameters... integer(psb_ipk_), intent(in) :: m - integer(psb_ipk_), intent(in) :: irw(:) + integer(psb_lpk_), intent(in) :: irw(:) complex(psb_dpk_), intent(in) :: val(:,:) type(psb_z_multivect_type), intent(inout) :: x type(psb_desc_type), intent(in) :: desc_a @@ -734,9 +397,9 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) logical, intent(in), optional :: local !locals..... - integer(psb_ipk_) :: ictxt,i,& - & loc_rows,loc_cols,mglob,err_act, int_err(5) - integer(psb_ipk_) :: np, me, dupl_ + integer(psb_ipk_) :: i, loc_rows,loc_cols + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt, np, me, dupl_, err_act integer(psb_ipk_), allocatable :: irl(:) logical :: local_ character(len=20) :: name @@ -764,15 +427,11 @@ subroutine psb_zins_multivect(m, irw, val, x, desc_a, info, dupl,local) !... check parameters.... if (m < 0) then info = psb_err_iarg_neg_ - int_err(1) = 1 - int_err(2) = m - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/ione,m/)) goto 9999 else if (x%get_nrows() < desc_a%get_local_rows()) then info = 310 - int_err(1) = 5 - int_err(2) = 4 - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) goto 9999 endif diff --git a/base/tools/psb_zins_a.f90 b/base/tools/psb_zins_a.f90 new file mode 100644 index 000000000..7db797f8e --- /dev/null +++ b/base/tools/psb_zins_a.f90 @@ -0,0 +1,367 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! Subroutine: psb_zinsvi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:) - complex The source dense submatrix. +! x(:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_zinsvi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:) + complex(psb_dpk_),intent(inout) :: x(:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np, me, dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_zinsvi' + info=psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + + if (m == 0) return + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = val(i) + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + if (irl(i) > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + x(irl(i)) = x(irl(i)) + val(i) + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zinsvi + + + + +!!$ +!!$ Parallel Sparse BLAS version 3.5 +!!$ (C) Copyright 2006-2018 +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the PSBLAS group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! Subroutine: psb_zinsi +! Insert dense submatrix to dense matrix. Note: the row indices in IRW +! are assumed to be in global numbering and are converted on the fly. +! Row indices not belonging to the current process are silently discarded. +! +! Arguments: +! m - integer. Number of rows of submatrix belonging to +! val to be inserted. +! irw(:) - integer Row indices of rows of val (global numbering) +! val(:,:) - complex The source dense submatrix. +! x(:,:) - complex The destination dense matrix. +! desc_a - type(psb_desc_type). The communication descriptor. +! info - integer. return code +! dupl - integer What to do with duplicates: +! psb_dupl_ovwrt_ overwrite +! psb_dupl_add_ add +subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local) + use psb_base_mod, psb_protect_name => psb_zinsi + use psi_mod + implicit none + + ! m rows number of submatrix belonging to val to be inserted + + ! ix x global-row corresponding to position at which val submatrix + ! must be inserted + + !....parameters... + integer(psb_ipk_), intent(in) :: m + integer(psb_lpk_), intent(in) :: irw(:) + complex(psb_dpk_), intent(in) :: val(:,:) + complex(psb_dpk_),intent(inout) :: x(:,:) + type(psb_desc_type), intent(in) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: dupl + logical, intent(in), optional :: local + + !locals..... + integer(psb_ipk_) :: i,loc_row,j,n, loc_rows,loc_cols,err_act + integer(psb_lpk_) :: mglob + integer(psb_ipk_) :: ictxt,np,me,dupl_ + integer(psb_ipk_), allocatable :: irl(:) + logical :: local_ + character(len=20) :: name + + name = 'psb_zinsi' + info = psb_success_ + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + return + end if + + ictxt=desc_a%get_context() + + call psb_info(ictxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + !... check parameters.... + if (m < 0) then + info = psb_err_iarg_neg_ + call psb_errpush(info,name,i_err=(/ione,m/)) + goto 9999 + else if (size(x, dim=1) < desc_a%get_local_rows()) then + info = 310 + call psb_errpush(info,name,i_err=(/5_psb_ipk_,4_psb_ipk_/)) + goto 9999 + endif + if (m == 0) return + + loc_rows = desc_a%get_local_rows() + loc_cols = desc_a%get_local_cols() + mglob = desc_a%get_global_rows() + + n = min(size(val,2),size(x,2)) + + if (present(dupl)) then + dupl_ = dupl + else + dupl_ = psb_dupl_ovwrt_ + endif + + allocate(irl(m),stat=info) + if (info /= psb_success_) then + info = psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + if (present(local)) then + local_ = local + else + local_ = .false. + endif + + if (local_) then + irl(1:m) = irw(1:m) + else + call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.) + end if + + select case(dupl_) + case(psb_dupl_ovwrt_) + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = val(i,j) + end do + end if + enddo + + case(psb_dupl_add_) + + do i = 1, m + !loop over all val's rows + + ! row actual block row + loc_row = irl(i) + if (loc_row > 0) then + ! this row belongs to me + ! copy i-th row of block val in x + do j=1,n + x(loc_row,j) = x(loc_row,j) + val(i,j) + end do + end if + enddo + + case default + info = 321 + call psb_errpush(info,name) + goto 9999 + end select + deallocate(irl) + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_zinsi + diff --git a/base/tools/psb_zspalloc.f90 b/base/tools/psb_zspalloc.f90 index 6687825fd..81099dcbd 100644 --- a/base/tools/psb_zspalloc.f90 +++ b/base/tools/psb_zspalloc.f90 @@ -52,16 +52,17 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) integer(psb_ipk_), optional, intent(in) :: nnz !locals - integer(psb_ipk_) :: ictxt, dectype - integer(psb_ipk_) :: np,me,loc_row,loc_col,& - & length_ia1,length_ia2, err_act,m,n - integer(psb_ipk_) :: int_err(5) + integer(psb_ipk_) :: ictxt, np, me, err_act + integer(psb_ipk_) :: loc_row,loc_col, nnz_, dectype + integer(psb_lpk_) :: m, n integer(psb_ipk_) :: debug_level, debug_unit - character(len=20) :: name, ch_err + character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if name = 'psb_zspall' debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -87,26 +88,23 @@ subroutine psb_zspalloc(a, desc_a, info, nnz) if (present(nnz))then if (nnz < 0) then info=45 - int_err(1)=7 - int_err(2)=nnz - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,i_err=(/7_psb_ipk_,nnz/)) goto 9999 endif - length_ia1=nnz - length_ia2=nnz + nnz_ = nnz else - length_ia1=max(1,5*loc_row) + nnz_ = max(1,5*loc_row) endif if (debug_level >= psb_debug_ext_) & - & write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1 + & write(debug_unit,*) me,' ',trim(name), & + & ':allocating size:',loc_row,loc_col,nnz_ call a%free() !....allocate aspk, ia1, ia2..... - call a%csall(loc_row,loc_col,info,nz=length_ia1) + call a%csall(loc_row,loc_col,info,nz=nnz_) if(info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='sp_all' - call psb_errpush(info,name,int_err) + call psb_errpush(info,name,a_err='sp_all') goto 9999 end if diff --git a/base/tools/psb_zspasb.f90 b/base/tools/psb_zspasb.f90 index 995782b81..9db285505 100644 --- a/base/tools/psb_zspasb.f90 +++ b/base/tools/psb_zspasb.f90 @@ -62,15 +62,12 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold) character(len=*), optional, intent(in) :: afmt class(psb_z_base_sparse_mat), intent(in), optional :: mold !....Locals.... - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: np,me,n_col, err_act - integer(psb_ipk_) :: spstate - integer(psb_ipk_) :: ictxt,n_row + integer(psb_ipk_) :: ictxt,np,me, err_act + integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err info = psb_success_ - int_err(1)=0 name = 'psb_spasb' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() diff --git a/base/tools/psb_zspfree.f90 b/base/tools/psb_zspfree.f90 index 101462326..b002999da 100644 --- a/base/tools/psb_zspfree.f90 +++ b/base/tools/psb_zspfree.f90 @@ -51,10 +51,12 @@ subroutine psb_zspfree(a, desc_a,info) integer(psb_ipk_) :: ictxt, err_act character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_zspfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if if (.not.psb_is_ok_desc(desc_a)) then info = psb_err_forgot_spall_ diff --git a/base/tools/psb_zsphalo.F90 b/base/tools/psb_zsphalo.F90 index 4c479ac56..e17d30a56 100644 --- a/base/tools/psb_zsphalo.F90 +++ b/base/tools/psb_zsphalo.F90 @@ -75,15 +75,22 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& character(len=5), optional :: outfmt integer(psb_ipk_), intent(in), optional :: data ! ...local scalars.... - integer(psb_ipk_) :: np,me,counter,proc,i, & - & n_el_send,k,n_el_recv,ictxt, idx, r, tot_elem,& + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: counter,proc,i, & + & n_el_send,k,n_el_recv,idx, r, tot_elem,& & n_elem, j, ipx,mat_recv, iszs, iszr,idxs,idxr,nz,& & irmin,icmin,irmax,icmax,data_,ngtz,totxch,nxs, nxr,& & l1, err_act - integer(psb_mpik_) :: icomm, minfo - integer(psb_mpik_), allocatable :: brvindx(:), & + integer(psb_mpk_) :: icomm, minfo + integer(psb_mpk_), allocatable :: brvindx(:), & & rvsz(:), bsdindx(:),sdsz(:) +#if defined(IPK4) && defined(LPK8) + ! If globals are 8 bytes but locals are 4, things get tricky + integer(psb_ipk_), allocatable :: liasnd(:), ljasnd(:) + integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:), iarcv(:), jarcv(:) +#else integer(psb_ipk_), allocatable :: iasnd(:), jasnd(:) +#endif complex(psb_dpk_), allocatable :: valsnd(:) type(psb_z_coo_sparse_mat), allocatable :: acoo integer(psb_ipk_), pointer :: idxv(:) @@ -94,10 +101,12 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& integer(psb_ipk_) :: debug_level, debug_unit character(len=20) :: name, ch_err - if(psb_get_errstatus() /= 0) return info=psb_success_ name='psb_zsphalo' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() @@ -152,6 +161,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& If (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + select case(data_) case(psb_comm_halo_,psb_comm_ext_ ) ! Do not accept OVRLAP_INDEX any longer. @@ -172,7 +182,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& idxs = 0 idxr = 0 - call acoo%allocate(izero,a%get_ncols(),info) + call acoo%allocate(izero,a%get_ncols()) call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info) @@ -195,8 +205,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& counter = counter+n_el_send+3 Enddo - call mpi_alltoall(sdsz,1,psb_mpi_def_integer,& - & rvsz,1,psb_mpi_def_integer,icomm,minfo) + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoall') @@ -225,14 +235,417 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& if (debug_level >= psb_debug_outer_)& & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& & ' Send:',sdsz(:),' Receive:',rvsz(:) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='psb_sp_reall') - goto 9999 - end if mat_recv = iszr iszs=sum(sdsz) - call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) +#if defined(IPK4) && defined(LPK8) + ! If globals are 8 bytes but locals are not, things get tricky + if (info == psb_success_) call psb_ensure_size(max(iszs,1),liasnd,info) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),ljasnd,info) + + if (info == psb_success_) call psb_ensure_size(max(iszr,1),iarcv,info) + if (info == psb_success_) call psb_ensure_size(max(iszr,1),jarcv,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv=ipdxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=ipdxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + call a%csget(idx,idx,ngtz,liasnd,ljasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + ipx = ipx + 1 + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) then + call psb_loc_to_glob(liasnd(1:nz),iasnd(1:nz),desc_a,info,iact='I') + else + iasnd(1:nz) = liasnd(1:nz) + end if + if (colcnv_) then + call psb_loc_to_glob(ljasnd(1:nz),jasnd(1:nz),desc_a,info,iact='I') + else + jasnd(1:nz) = ljasnd(1:nz) + end if + + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& + & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & iarcv,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & jarcv,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) then + call psb_glob_to_loc(iarcv(1:iszr),acoo%ia(1:iszr),desc_a,info,iact='I') + else + acoo%ia(1:iszr) = iarcv(1:iszr) + end if + if (colcnv_) then + call psb_glob_to_loc(jarcv(1:iszr),acoo%ja(1:iszr),desc_a,info,iact='I') + else + acoo%ja(1:iszr) = jarcv(1:iszr) + end if + +#else + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + + l1 = 0 + ipx = 1 + counter=1 + idx = 0 + + tot_elem=0 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv=ipdxv(counter+psb_n_elem_recv_) + counter=counter+n_el_recv + n_el_send=ipdxv(counter+psb_n_elem_send_) + + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,& + & append=.true.,nzin=tot_elem) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_sp_getrow' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tot_elem=tot_elem+n_elem + Enddo + ipx = ipx + 1 + counter = counter+n_el_send+3 + Enddo + nz = tot_elem + + if (rowcnv_) call psb_loc_to_glob(iasnd(1:nz),desc_a,info,iact='I') + if (colcnv_) call psb_loc_to_glob(jasnd(1:nz),desc_a,info,iact='I') + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_loc_to_glob' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& + & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_,& + & acoo%ia,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_,& + & acoo%ja,rvsz,brvindx,psb_mpi_ipk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='mpi_alltoallv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! + ! Convert into local numbering + ! + if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') + if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') +#endif + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psbglob_to_loc' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + l1 = 0 + call acoo%set_nrows(izero) + ! + irmin = huge(irmin) + icmin = huge(icmin) + irmax = 0 + icmax = 0 + Do i=1,iszr + r=(acoo%ia(i)) + k=(acoo%ja(i)) + ! Just in case some of the conversions were out-of-range + If ((r>0).and.(k>0)) Then + l1=l1+1 + acoo%val(l1) = acoo%val(i) + acoo%ia(l1) = r + acoo%ja(l1) = k + irmin = min(irmin,r) + irmax = max(irmax,r) + icmin = min(icmin,k) + icmax = max(icmax,k) + End If + Enddo + if (rowscale_) then + call acoo%set_nrows(max(irmax-irmin+1,0)) + acoo%ia(1:l1) = acoo%ia(1:l1) - irmin + 1 + else + call acoo%set_nrows(irmax) + end if + if (colscale_) then + call acoo%set_ncols(max(icmax-icmin+1,0)) + acoo%ja(1:l1) = acoo%ja(1:l1) - icmin + 1 + else + call acoo%set_ncols(icmax) + end if + + call acoo%set_nzeros(l1) + call acoo%set_sorted(.false.) + + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),& + & ': End data exchange',counter,l1 + + call move_alloc(acoo,blk%a) + + ! Do we expect any duplicates to appear???? + call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spcnv' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + Deallocate(brvindx,bsdindx,rvsz,sdsz,& + & iasnd,jasnd,valsnd,stat=info) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Done' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +End Subroutine psb_zsphalo + + +Subroutine psb_lzsphalo(a,desc_a,blk,info,rowcnv,colcnv,& + & rowscale,colscale,outfmt,data) + use psb_base_mod, psb_protect_name => psb_lzsphalo + +#ifdef MPI_MOD + use mpi +#endif + Implicit None +#ifdef MPI_H + include 'mpif.h' +#endif + + Type(psb_lzspmat_type),Intent(in) :: a + Type(psb_lzspmat_type),Intent(inout) :: blk + Type(psb_desc_type),Intent(in), target :: desc_a + integer(psb_ipk_), intent(out) :: info + logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale + character(len=5), optional :: outfmt + integer(psb_ipk_), intent(in), optional :: data + ! ...local scalars.... + integer(psb_ipk_) :: ictxt, np,me + integer(psb_ipk_) :: counter, proc, i, & + & n_el_send,n_el_recv,& + & n_elem, j, ipx,mat_recv, idxs,idxr,nz,& + & data_,totxch,nxs, nxr + integer(psb_lpk_) :: r, k, irmin, irmax, icmin, icmax, iszs, iszr, & + & lidx, l1, lnr, lnc, idx, ngtz, tot_elem + integer(psb_mpk_) :: icomm, minfo + integer(psb_mpk_), allocatable :: brvindx(:), & + & rvsz(:), bsdindx(:),sdsz(:) + integer(psb_lpk_), allocatable :: iasnd(:), jasnd(:) + complex(psb_dpk_), allocatable :: valsnd(:) + type(psb_lz_coo_sparse_mat), allocatable :: acoo + integer(psb_ipk_), pointer :: idxv(:) + class(psb_i_base_vect_type), pointer :: pdxv + integer(psb_ipk_), allocatable :: ipdxv(:) + logical :: rowcnv_,colcnv_,rowscale_,colscale_ + character(len=5) :: outfmt_ + integer(psb_ipk_) :: debug_level, debug_unit, err_act + character(len=20) :: name, ch_err + + info=psb_success_ + name='psb_zsphalo' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + icomm = desc_a%get_mpic() + + Call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),': Start' + + if (present(rowcnv)) then + rowcnv_ = rowcnv + else + rowcnv_ = .true. + endif + if (present(colcnv)) then + colcnv_ = colcnv + else + colcnv_ = .true. + endif + if (present(rowscale)) then + rowscale_ = rowscale + else + rowscale_ = .false. + endif + if (present(colscale)) then + colscale_ = colscale + else + colscale_ = .false. + endif + if (present(data)) then + data_ = data + else + data_ = psb_comm_halo_ + endif + + if (present(outfmt)) then + outfmt_ = psb_toupper(outfmt) + else + outfmt_ = 'CSR' + endif + + Allocate(brvindx(np+1),& + & rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + end if + + If (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Data selector',data_ + + select case(data_) + case(psb_comm_halo_,psb_comm_ext_ ) + ! Do not accept OVRLAP_INDEX any longer. + case default + call psb_errpush(psb_err_from_subroutine_,name,a_err='wrong Data selector') + goto 9999 + end select + + + sdsz(:)=0 + rvsz(:)=0 + l1 = 0 + ipx = 1 + brvindx(ipx) = 0 + bsdindx(ipx) = 0 + counter=1 + idx = 0 + idxs = 0 + idxr = 0 + lnc = a%get_ncols() + call acoo%allocate(lzero,lnc) + + + call desc_a%get_list(data_,pdxv,totxch,nxr,nxs,info) + ipdxv = pdxv%get_vect() + ! For all rows in the halo descriptor, extract and send/receive. + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv = ipdxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = ipdxv(counter+psb_n_elem_send_) + tot_elem = 0 + Do j=0,n_el_send-1 + idx = ipdxv(counter+psb_elem_send_+j) + n_elem = a%get_nz_row(idx) + tot_elem = tot_elem+n_elem + Enddo + sdsz(proc+1) = tot_elem + call acoo%set_nrows(acoo%get_nrows() + n_el_recv) + counter = counter+n_el_send+3 + Enddo + + call mpi_alltoall(sdsz,1,psb_mpi_mpk_,& + & rvsz,1,psb_mpi_mpk_,icomm,minfo) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='mpi_alltoall') + goto 9999 + end if + + idxs = 0 + idxr = 0 + counter = 1 + Do + proc=ipdxv(counter) + if (proc == -1) exit + n_el_recv = ipdxv(counter+psb_n_elem_recv_) + counter = counter+n_el_recv + n_el_send = ipdxv(counter+psb_n_elem_send_) + + bsdindx(proc+1) = idxs + idxs = idxs + sdsz(proc+1) + brvindx(proc+1) = idxr + idxr = idxr + rvsz(proc+1) + counter = counter+n_el_send+3 + Enddo + + iszr=sum(rvsz) + call acoo%reallocate(max(iszr,1)) + if (debug_level >= psb_debug_outer_)& + & write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),& + & ' Send:',sdsz(:),' Receive:',rvsz(:) + mat_recv = iszr + iszs=sum(sdsz) + if (info == psb_success_) call psb_ensure_size(max(iszs,1),iasnd,info) if (info == psb_success_) call psb_ensure_size(max(iszs,1),jasnd,info) if (info == psb_success_) call psb_ensure_size(max(iszs,1),valsnd,info) if (info /= psb_success_) then @@ -241,6 +654,11 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& goto 9999 end if + if (info /= psb_success_) then + info=psb_err_from_subroutine_; ch_err='psb_sp_reall' + call psb_errpush(info,name,a_err=ch_err); goto 9999 + end if + l1 = 0 ipx = 1 counter=1 @@ -282,10 +700,10 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& call mpi_alltoallv(valsnd,sdsz,bsdindx,psb_mpi_c_dpk_,& & acoo%val,rvsz,brvindx,psb_mpi_c_dpk_,icomm,minfo) - call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& - & acoo%ia,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) - call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_ipk_integer,& - & acoo%ja,rvsz,brvindx,psb_mpi_ipk_integer,icomm,minfo) + call mpi_alltoallv(iasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & acoo%ia,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) + call mpi_alltoallv(jasnd,sdsz,bsdindx,psb_mpi_lpk_,& + & acoo%ja,rvsz,brvindx,psb_mpi_lpk_,icomm,minfo) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='mpi_alltoallv') @@ -297,7 +715,6 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& ! if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I') if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I') - if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psbglob_to_loc') @@ -305,7 +722,7 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& end if l1 = 0 - call acoo%set_nrows(izero) + call acoo%set_nrows(lzero) ! irmin = huge(irmin) icmin = huge(icmin) @@ -368,4 +785,4 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,& return -End Subroutine psb_zsphalo +End Subroutine psb_lzsphalo diff --git a/base/tools/psb_zspins.f90 b/base/tools/psb_zspins.f90 index 047597ff0..84fa87a12 100644 --- a/base/tools/psb_zspins.f90 +++ b/base/tools/psb_zspins.f90 @@ -56,10 +56,11 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) !....parameters... type(psb_desc_type), intent(inout) :: desc_a type(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info - logical, intent(in), optional :: rebuild, local + integer(psb_ipk_), intent(out) :: info + logical, intent(in), optional :: rebuild, local !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate @@ -68,7 +69,6 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) integer(psb_ipk_), parameter :: relocsz=200 logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -122,9 +122,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) else allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if @@ -133,9 +132,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) & mask=(ila(1:nz)>0)) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if nrow = desc_a%get_local_rows() @@ -159,31 +157,24 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() + allocate(ila(nz),jla(nz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate',i_err=(/info/)) + goto 9999 + end if if (local_) then - call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + ila(1:nz) = ia(1:nz) + jla(1:nz) = ja(1:nz) else - allocate(ila(nz),jla(nz),stat=info) - if (info /= psb_success_) then - ierr(1) = info - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) - goto 9999 - end if - call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info) if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info) - - call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + end if + call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 end if else info = psb_err_invalid_cd_state_ @@ -210,9 +201,10 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) type(psb_desc_type), intent(in) :: desc_ar type(psb_desc_type), intent(inout) :: desc_ac type(psb_zspmat_type), intent(inout) :: a - integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) + integer(psb_ipk_), intent(in) :: nz + integer(psb_lpk_), intent(in) :: ia(:),ja(:) complex(psb_dpk_), intent(in) :: val(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info !locals..... integer(psb_ipk_) :: nrow, err_act, ncol, spstate @@ -220,7 +212,6 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) logical, parameter :: debug=.false. integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), allocatable :: ila(:),jla(:) - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -268,9 +259,8 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if @@ -279,9 +269,8 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) & mask=(ila(1:nz)>0)) if (psb_errstatus_fatal()) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if @@ -327,7 +316,7 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) type(psb_desc_type), intent(inout) :: desc_a type(psb_zspmat_type), intent(inout) :: a integer(psb_ipk_), intent(in) :: nz - type(psb_i_vect_type), intent(inout) :: ia,ja + type(psb_l_vect_type), intent(inout) :: ia,ja type(psb_z_vect_type), intent(inout) :: val integer(psb_ipk_), intent(out) :: info logical, intent(in), optional :: rebuild, local @@ -340,7 +329,6 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) logical :: rebuild_, local_ integer(psb_ipk_), allocatable :: ila(:),jla(:) real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput - integer(psb_ipk_) :: ierr(5) character(len=20) :: name info = psb_success_ @@ -394,9 +382,8 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) else allocate(ila(nz),jla(nz),stat=info) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) + & a_err='allocate',i_err=(/info/)) goto 9999 end if if (ia%is_dev()) call ia%sync() @@ -407,9 +394,8 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) call desc_a%indxmap%g2l_ins(ja%v%v(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0)) if (info /= psb_success_) then - ierr(1) = info call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='psb_cdins',i_err=ierr) + & a_err='psb_cdins',i_err=(/info/)) goto 9999 end if nrow = desc_a%get_local_rows() @@ -433,33 +419,28 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() + allocate(ila(nz),jla(nz),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_ai_,name,& + & a_err='allocate',i_err=(/info/)) + goto 9999 + end if + if (ia%is_dev()) call ia%sync() + if (ja%is_dev()) call ja%sync() + if (val%is_dev()) call val%sync() + if (local_) then - call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + ila(1:nz) = ia%v%v(1:nz) + jla(1:nz) = ja%v%v(1:nz) else - allocate(ila(nz),jla(nz),stat=info) - if (info /= psb_success_) then - ierr(1) = info - call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='allocate',i_err=ierr) - goto 9999 - end if - if (ia%is_dev()) call ia%sync() - if (ja%is_dev()) call ja%sync() - if (val%is_dev()) call val%sync() - call desc_a%indxmap%g2l(ia%v%v(1:nz),ila(1:nz),info) if (info == 0) call desc_a%indxmap%g2l(ja%v%v(1:nz),jla(1:nz),info) - if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info) - if (info /= psb_success_) then - info=psb_err_from_subroutine_ - call psb_errpush(info,name,a_err='a%csput') - goto 9999 - end if + end if + if (info == 0) call a%csput(nz,ila,jla,val%v%v,ione,nrow,ione,ncol,info) + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + call psb_errpush(info,name,a_err='a%csput') + goto 9999 end if else info = psb_err_invalid_cd_state_ diff --git a/base/tools/psb_zsprn.f90 b/base/tools/psb_zsprn.f90 index 36942b394..aa87a8f07 100644 --- a/base/tools/psb_zsprn.f90 +++ b/base/tools/psb_zsprn.f90 @@ -53,15 +53,12 @@ Subroutine psb_zsprn(a, desc_a,info,clear) logical, intent(in), optional :: clear !locals - integer(psb_ipk_) :: ictxt,np,me,err,err_act + integer(psb_ipk_) :: ictxt,np,me,err_act integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: int_err(5) character(len=20) :: name logical :: clear_ info = psb_success_ - err = 0 - int_err(1)=0 name = 'psb_zsprn' call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() diff --git a/cbind/Makefile b/cbind/Makefile index 3d078a9cd..9beb16046 100644 --- a/cbind/Makefile +++ b/cbind/Makefile @@ -12,7 +12,6 @@ lib: based precd krylovd /bin/cp -p $(CPUPDFLAG) *$(.mod) $(MODDIR) - based: cd base && $(MAKE) lib LIBNAME=$(LIBNAME) precd: based diff --git a/cbind/base/psb_base_tools_cbind_mod.F90 b/cbind/base/psb_base_tools_cbind_mod.F90 index a8f87496b..2b7e38564 100644 --- a/cbind/base/psb_base_tools_cbind_mod.F90 +++ b/cbind/base/psb_base_tools_cbind_mod.F90 @@ -2,20 +2,21 @@ module psb_base_tools_cbind_mod use iso_c_binding use psb_base_mod use psb_objhandle_mod + use psb_cpenv_mod use psb_base_string_cbind_mod contains function psb_c_error() bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res res = 0 call psb_error() end function psb_c_error function psb_c_clean_errstack() bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res res = 0 call psb_clean_errstack() end function psb_c_clean_errstack @@ -23,12 +24,13 @@ contains function psb_c_cdall_vg(ng,vg,ictxt,cdh) bind(c,name='psb_c_cdall_vg') result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: ng, ictxt - integer(psb_c_int) :: vg(*) + integer(psb_c_ipk) :: res + integer(psb_c_lpk), value :: ng + integer(psb_c_ipk), value :: ictxt + integer(psb_c_ipk) :: vg(*) type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp - integer :: info + integer(psb_c_ipk) :: info res = -1 if (ng <=0) then @@ -56,12 +58,12 @@ contains function psb_c_cdall_vl(nl,vl,ictxt,cdh) bind(c,name='psb_c_cdall_vl') result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nl, ictxt - integer(psb_c_int) :: vl(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nl, ictxt + integer(psb_c_lpk) :: vl(*) type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp - integer :: info + integer(psb_c_ipk) :: info, ixb res = -1 if (nl <=0) then @@ -78,8 +80,14 @@ contains allocate(descp,stat=info) if (info < 0) return + + ixb = psb_c_get_index_base() - call psb_cdall(ictxt,descp,info,vl=vl(1:nl)) + if (ixb == 1) then + call psb_cdall(ictxt,descp,info,vl=vl(1:nl)) + else + call psb_cdall(ictxt,descp,info,vl=(vl(1:nl)+(1-ixb))) + end if cdh%item = c_loc(descp) res = info @@ -88,11 +96,11 @@ contains function psb_c_cdall_nl(nl,ictxt,cdh) bind(c,name='psb_c_cdall_nl') result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nl, ictxt + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nl, ictxt type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp - integer :: info + integer(psb_c_ipk) :: info res = -1 if (nl <=0) then @@ -119,11 +127,12 @@ contains function psb_c_cdall_repl(n,ictxt,cdh) bind(c,name='psb_c_cdall_repl') result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: n, ictxt + integer(psb_c_ipk) :: res + integer(psb_c_lpk), value :: n + integer(psb_c_ipk), value :: ictxt type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp - integer :: info + integer(psb_c_ipk) :: info res = -1 if (n <=0) then @@ -150,10 +159,10 @@ contains function psb_c_cdasb(cdh) bind(c,name='psb_c_cdasb') result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -169,10 +178,10 @@ contains function psb_c_cdfree(cdh) bind(c,name='psb_c_cdfree') result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -190,13 +199,13 @@ contains function psb_c_cdins(nz,ia,ja,cdh) bind(c,name='psb_c_cdins') result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz type(psb_c_object_type) :: cdh - integer(psb_c_int) :: ia(*),ja(*) + integer(psb_c_lpk) :: ia(*),ja(*) type(psb_desc_type), pointer :: descp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -213,7 +222,7 @@ contains function psb_c_cd_get_local_rows(cdh) bind(c,name='psb_c_cd_get_local_rows') result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp @@ -234,7 +243,7 @@ contains function psb_c_cd_get_local_cols(cdh) bind(c,name='psb_c_cd_get_local_cols') result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp @@ -253,7 +262,7 @@ contains function psb_c_cd_get_global_rows(cdh) bind(c,name='psb_c_cd_get_global_rows') result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_lpk) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp @@ -274,7 +283,7 @@ contains function psb_c_cd_get_global_cols(cdh) bind(c,name='psb_c_cd_get_global_cols') result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_lpk) :: res type(psb_c_object_type) :: cdh type(psb_desc_type), pointer :: descp diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h index b78562d52..055283b41 100644 --- a/cbind/base/psb_c_base.h +++ b/cbind/base/psb_c_base.h @@ -15,11 +15,21 @@ extern "C" { #include -#if defined(LONG_INTEGERS_) - typedef int64_t psb_i_t; -#else + typedef int32_t psb_m_t; + +#if defined(IPK4) && defined(LPK4) typedef int32_t psb_i_t; + typedef int32_t psb_l_t; +#elif defined(IPK4) && defined(LPK8) + typedef int32_t psb_i_t; + typedef int64_t psb_l_t; +#elif defined(IPK8) && defined(LPK8) + typedef int64_t psb_i_t; + typedef int64_t psb_l_t; +#else #endif + typedef int64_t psb_e_t; + typedef float psb_s_t; typedef double psb_d_t; typedef float complex psb_c_t; @@ -56,7 +66,10 @@ extern "C" { psb_i_t psb_c_get_index_base(); void psb_c_set_index_base(psb_i_t base); + void psb_c_mbcast(psb_i_t ictxt, psb_i_t n, psb_m_t *v, psb_i_t root); void psb_c_ibcast(psb_i_t ictxt, psb_i_t n, psb_i_t *v, psb_i_t root); + void psb_c_lbcast(psb_i_t ictxt, psb_i_t n, psb_l_t *v, psb_i_t root); + void psb_c_ebcast(psb_i_t ictxt, psb_i_t n, psb_e_t *v, psb_i_t root); void psb_c_sbcast(psb_i_t ictxt, psb_i_t n, psb_s_t *v, psb_i_t root); void psb_c_dbcast(psb_i_t ictxt, psb_i_t n, psb_d_t *v, psb_i_t root); void psb_c_cbcast(psb_i_t ictxt, psb_i_t n, psb_c_t *v, psb_i_t root); @@ -65,19 +78,19 @@ extern "C" { /* Descriptor/integer routines */ psb_c_descriptor* psb_c_new_descriptor(); - psb_i_t psb_c_cdall_vg(psb_i_t ng, psb_i_t *vg, psb_i_t ictxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_vl(psb_i_t nl, psb_i_t *vl, psb_i_t ictxt, psb_c_descriptor *cd); + psb_i_t psb_c_cdall_vg(psb_l_t ng, psb_i_t *vg, psb_i_t ictxt, psb_c_descriptor *cd); + psb_i_t psb_c_cdall_vl(psb_i_t nl, psb_l_t *vl, psb_i_t ictxt, psb_c_descriptor *cd); psb_i_t psb_c_cdall_nl(psb_i_t nl, psb_i_t ictxt, psb_c_descriptor *cd); - psb_i_t psb_c_cdall_repl(psb_i_t n, psb_i_t ictxt, psb_c_descriptor *cd); + psb_i_t psb_c_cdall_repl(psb_l_t n, psb_i_t ictxt, psb_c_descriptor *cd); psb_i_t psb_c_cdasb(psb_c_descriptor *cd); psb_i_t psb_c_cdfree(psb_c_descriptor *cd); - psb_i_t psb_c_cdins(psb_i_t nz, const psb_i_t *ia, const psb_i_t *ja, psb_c_descriptor *cd); + psb_i_t psb_c_cdins(psb_i_t nz, const psb_l_t *ia, const psb_l_t *ja, psb_c_descriptor *cd); psb_i_t psb_c_cd_get_local_rows(psb_c_descriptor *cd); psb_i_t psb_c_cd_get_local_cols(psb_c_descriptor *cd); - psb_i_t psb_c_cd_get_global_rows(psb_c_descriptor *cd); - psb_i_t psb_c_cd_get_global_rows(psb_c_descriptor *cd); + psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd); + psb_l_t psb_c_cd_get_global_rows(psb_c_descriptor *cd); /* legal values for upd argument */ diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index 53cfd61de..c6bea6b6d 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -18,14 +18,14 @@ typedef struct PSB_C_CSPMAT { /* dense vectors */ psb_c_cvector* psb_c_new_cvector(); psb_i_t psb_c_cvect_get_nrows(psb_c_cvector *xh); -psb_c_t *psb_c_cvect_get_cpy( psb_c_cvector *xh); +psb_c_t *psb_c_cvect_get_cpy( psb_c_cvector *xh); psb_i_t psb_c_cvect_f_get_cpy(psb_c_t *v, psb_c_cvector *xh); psb_i_t psb_c_cvect_zero(psb_c_cvector *xh); psb_i_t psb_c_cgeall(psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeins(psb_i_t nz, const psb_i_t *irw, const psb_c_t *val, +psb_i_t psb_c_cgeins(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val, psb_c_cvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_cgeins_add(psb_i_t nz, const psb_i_t *irw, const psb_c_t *val, +psb_i_t psb_c_cgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_c_t *val, psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_cgeasb(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_cgefree(psb_c_cvector *xh, psb_c_descriptor *cdh); @@ -35,8 +35,8 @@ psb_c_cspmat* psb_c_new_cspmat(); psb_i_t psb_c_cspall(psb_c_cspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_cspasb(psb_c_cspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_cspfree(psb_c_cspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_cspins(psb_i_t nz, const psb_i_t *irw, const psb_i_t *icl, const psb_c_t *val, - psb_c_cspmat *mh, psb_c_descriptor *cdh); +psb_i_t psb_c_cspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, + const psb_c_t *val, psb_c_cspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_cmat_get_nrows(psb_c_cspmat *mh); psb_i_t psb_c_cmat_get_ncols(psb_c_cspmat *mh); diff --git a/cbind/base/psb_c_ccomm.c b/cbind/base/psb_c_ccomm.c index 24e3f3587..c11327722 100644 --- a/cbind/base/psb_c_ccomm.c +++ b/cbind/base/psb_c_ccomm.c @@ -6,7 +6,7 @@ psb_c_t* psb_c_cvgather(psb_c_cvector *xh, psb_c_descriptor *cdh) { psb_c_t *temp=NULL; - psb_i_t vsize=0; + psb_l_t vsize=0; if ((vsize=psb_c_cd_get_global_rows(cdh))<0) return(temp); diff --git a/cbind/base/psb_c_ccomm.h b/cbind/base/psb_c_ccomm.h index 774f34f27..dc45b4e90 100644 --- a/cbind/base/psb_c_ccomm.h +++ b/cbind/base/psb_c_ccomm.h @@ -12,7 +12,7 @@ extern "C" { psb_i_t psb_c_covrl(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_covrl_opt(psb_c_cvector *xh, psb_c_descriptor *cdh, psb_i_t update, psb_i_t mode); - psb_i_t psb_c_cvscatter(psb_i_t ng, psb_c_t *gx, psb_c_cvector *xh, psb_c_descriptor *cdh); + psb_i_t psb_c_cvscatter(psb_l_t ng, psb_c_t *gx, psb_c_cvector *xh, psb_c_descriptor *cdh); psb_c_t* psb_c_cvgather(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_c_cspmat* psb_c_cspgather(psb_c_cspmat *ah, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_comm_cbind_mod.f90 b/cbind/base/psb_c_comm_cbind_mod.f90 index 389464a5d..c8c0e24c5 100644 --- a/cbind/base/psb_c_comm_cbind_mod.f90 +++ b/cbind/base/psb_c_comm_cbind_mod.f90 @@ -8,14 +8,14 @@ contains function psb_c_c_ovrl(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -39,15 +39,15 @@ contains function psb_c_c_ovrl_opt(xh,cdh,update,mode) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: update, mode + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: update, mode type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -72,14 +72,14 @@ contains function psb_c_c_halo(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -103,8 +103,8 @@ contains function psb_c_c_halo_opt(xh,cdh,tran,data,mode) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: data, mode + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: data, mode character(c_char) :: tran @@ -114,7 +114,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp character :: ftran - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -141,8 +141,8 @@ contains function psb_c_c_vscatter(ng,gx,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: ng + integer(psb_c_ipk) :: res + integer(psb_c_lpk), value :: ng complex(c_float_complex), target :: gx(*) type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh @@ -150,7 +150,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: vp complex(psb_spk_), pointer :: pgx(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -175,7 +175,7 @@ contains function psb_c_cvgather(v,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res complex(c_float_complex), target :: v(*) type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh @@ -183,7 +183,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: vp complex(psb_spk_), allocatable :: fv(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -208,13 +208,13 @@ contains function psb_c_cspgather(gah,ah,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: ah, gah type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap, gap - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index ff4e6997f..95baca5d6 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -18,14 +18,14 @@ typedef struct PSB_C_DSPMAT { /* dense vectors */ psb_c_dvector* psb_c_new_dvector(); psb_i_t psb_c_dvect_get_nrows(psb_c_dvector *xh); -psb_d_t *psb_c_dvect_get_cpy( psb_c_dvector *xh); +psb_d_t *psb_c_dvect_get_cpy( psb_c_dvector *xh); psb_i_t psb_c_dvect_f_get_cpy(psb_d_t *v, psb_c_dvector *xh); psb_i_t psb_c_dvect_zero(psb_c_dvector *xh); psb_i_t psb_c_dgeall(psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeins(psb_i_t nz, const psb_i_t *irw, const psb_d_t *val, +psb_i_t psb_c_dgeins(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val, psb_c_dvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_dgeins_add(psb_i_t nz, const psb_i_t *irw, const psb_d_t *val, +psb_i_t psb_c_dgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_d_t *val, psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgeasb(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh); @@ -35,8 +35,8 @@ psb_c_dspmat* psb_c_new_dspmat(); psb_i_t psb_c_dspall(psb_c_dspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_dspasb(psb_c_dspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_dspfree(psb_c_dspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_dspins(psb_i_t nz, const psb_i_t *irw, const psb_i_t *icl, const psb_d_t *val, - psb_c_dspmat *mh, psb_c_descriptor *cdh); +psb_i_t psb_c_dspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, + const psb_d_t *val, psb_c_dspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_dmat_get_nrows(psb_c_dspmat *mh); psb_i_t psb_c_dmat_get_ncols(psb_c_dspmat *mh); diff --git a/cbind/base/psb_c_dcomm.c b/cbind/base/psb_c_dcomm.c index 47e6e7800..8f3257ea4 100644 --- a/cbind/base/psb_c_dcomm.c +++ b/cbind/base/psb_c_dcomm.c @@ -6,7 +6,7 @@ psb_d_t* psb_c_dvgather(psb_c_dvector *xh, psb_c_descriptor *cdh) { psb_d_t *temp=NULL; - psb_i_t vsize=0; + psb_l_t vsize=0; if ((vsize=psb_c_cd_get_global_rows(cdh))<0) return(temp); diff --git a/cbind/base/psb_c_dcomm.h b/cbind/base/psb_c_dcomm.h index c032d34f3..cbffc3b1b 100644 --- a/cbind/base/psb_c_dcomm.h +++ b/cbind/base/psb_c_dcomm.h @@ -12,7 +12,7 @@ extern "C" { psb_i_t psb_c_dovrl(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dovrl_opt(psb_c_dvector *xh, psb_c_descriptor *cdh, psb_i_t update, psb_i_t mode); - psb_i_t psb_c_dvscatter(psb_i_t ng, psb_d_t *gx, psb_c_dvector *xh, psb_c_descriptor *cdh); + psb_i_t psb_c_dvscatter(psb_l_t ng, psb_d_t *gx, psb_c_dvector *xh, psb_c_descriptor *cdh); psb_d_t* psb_c_dvgather(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_c_dspmat* psb_c_dspgather(psb_c_dspmat *ah, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_psblas_cbind_mod.f90 b/cbind/base/psb_c_psblas_cbind_mod.f90 index ac9845623..a43923200 100644 --- a/cbind/base/psb_c_psblas_cbind_mod.f90 +++ b/cbind/base/psb_c_psblas_cbind_mod.f90 @@ -1,14 +1,14 @@ module psb_c_psblas_cbind_mod use iso_c_binding + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod contains function psb_c_cgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cvector) :: xh,yh type(psb_c_descriptor) :: cdh @@ -16,7 +16,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp,yp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -44,9 +44,6 @@ contains end function psb_c_cgeaxpby function psb_c_cgenrm2(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float_complex) :: res @@ -54,7 +51,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 @@ -74,9 +71,6 @@ contains end function psb_c_cgenrm2 function psb_c_cgeamax(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float_complex) :: res @@ -84,7 +78,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -103,9 +97,6 @@ contains end function psb_c_cgeamax function psb_c_cgeasum(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float_complex) :: res @@ -113,7 +104,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 @@ -134,9 +125,6 @@ contains function psb_c_cspnrmi(ah,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float_complex) :: res @@ -144,7 +132,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -163,9 +151,6 @@ contains end function psb_c_cspnrmi function psb_c_cgedot(xh,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none complex(c_float_complex) :: res @@ -173,7 +158,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp,yp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -197,11 +182,8 @@ contains function psb_c_cspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: ah type(psb_c_cvector) :: xh,yh @@ -210,7 +192,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp,yp type(psb_cspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -242,11 +224,8 @@ contains function psb_c_cspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: ah type(psb_c_cvector) :: xh,yh @@ -260,7 +239,7 @@ contains type(psb_cspmat_type), pointer :: ap character :: ftrans logical :: fdoswap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -294,11 +273,8 @@ contains function psb_c_cspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: ah type(psb_c_cvector) :: xh,yh @@ -307,7 +283,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp,yp type(psb_cspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index 3617451ca..5f5c52343 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -18,14 +18,14 @@ typedef struct PSB_C_SSPMAT { /* dense vectors */ psb_c_svector* psb_c_new_svector(); psb_i_t psb_c_svect_get_nrows(psb_c_svector *xh); -psb_s_t *psb_c_svect_get_cpy( psb_c_svector *xh); +psb_s_t *psb_c_svect_get_cpy( psb_c_svector *xh); psb_i_t psb_c_svect_f_get_cpy(psb_s_t *v, psb_c_svector *xh); psb_i_t psb_c_svect_zero(psb_c_svector *xh); psb_i_t psb_c_sgeall(psb_c_svector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeins(psb_i_t nz, const psb_i_t *irw, const psb_s_t *val, +psb_i_t psb_c_sgeins(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val, psb_c_svector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_sgeins_add(psb_i_t nz, const psb_i_t *irw, const psb_s_t *val, +psb_i_t psb_c_sgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_s_t *val, psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sgeasb(psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sgefree(psb_c_svector *xh, psb_c_descriptor *cdh); @@ -35,8 +35,8 @@ psb_c_sspmat* psb_c_new_sspmat(); psb_i_t psb_c_sspall(psb_c_sspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_sspasb(psb_c_sspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_sspfree(psb_c_sspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_sspins(psb_i_t nz, const psb_i_t *irw, const psb_i_t *icl, const psb_s_t *val, - psb_c_sspmat *mh, psb_c_descriptor *cdh); +psb_i_t psb_c_sspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, + const psb_s_t *val, psb_c_sspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_smat_get_nrows(psb_c_sspmat *mh); psb_i_t psb_c_smat_get_ncols(psb_c_sspmat *mh); diff --git a/cbind/base/psb_c_scomm.c b/cbind/base/psb_c_scomm.c index 1c6ab36ec..a9b29641b 100644 --- a/cbind/base/psb_c_scomm.c +++ b/cbind/base/psb_c_scomm.c @@ -6,7 +6,7 @@ psb_s_t* psb_c_svgather(psb_c_svector *xh, psb_c_descriptor *cdh) { psb_s_t *temp=NULL; - psb_i_t vsize=0; + psb_l_t vsize=0; if ((vsize=psb_c_cd_get_global_rows(cdh))<0) return(temp); diff --git a/cbind/base/psb_c_scomm.h b/cbind/base/psb_c_scomm.h index 7a8ecc120..be1f81bf4 100644 --- a/cbind/base/psb_c_scomm.h +++ b/cbind/base/psb_c_scomm.h @@ -12,7 +12,7 @@ extern "C" { psb_i_t psb_c_sovrl(psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sovrl_opt(psb_c_svector *xh, psb_c_descriptor *cdh, psb_i_t update, psb_i_t mode); - psb_i_t psb_c_svscatter(psb_i_t ng, psb_s_t *gx, psb_c_svector *xh, psb_c_descriptor *cdh); + psb_i_t psb_c_svscatter(psb_l_t ng, psb_s_t *gx, psb_c_svector *xh, psb_c_descriptor *cdh); psb_s_t* psb_c_svgather(psb_c_svector *xh, psb_c_descriptor *cdh); psb_c_sspmat* psb_c_sspgather(psb_c_sspmat *ah, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index b91aa34ce..bb67f2b1e 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -11,11 +11,11 @@ contains function psb_c_cvect_get_nrows(xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cvector) :: xh type(psb_c_vect_type), pointer :: vp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -29,13 +29,13 @@ contains function psb_c_cvect_f_get_cpy(v,xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res complex(c_float_complex) :: v(*) type(psb_c_cvector) :: xh type(psb_c_vect_type), pointer :: vp complex(psb_spk_), allocatable :: fv(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -52,11 +52,11 @@ contains function psb_c_cvect_zero(xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cvector) :: xh type(psb_c_vect_type), pointer :: vp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -73,11 +73,11 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: mh type(psb_cspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = 0 if (c_associated(mh%item)) then @@ -96,11 +96,11 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: mh type(psb_cspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = 0 if (c_associated(mh%item)) then @@ -119,12 +119,12 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res character(c_char) :: name(*) type(psb_c_cspmat) :: mh type(psb_cspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info character(1024) :: fname res = 0 diff --git a/cbind/base/psb_c_tools_cbind_mod.F90 b/cbind/base/psb_c_tools_cbind_mod.F90 index 3c2571ecd..86bce5c96 100644 --- a/cbind/base/psb_c_tools_cbind_mod.F90 +++ b/cbind/base/psb_c_tools_cbind_mod.F90 @@ -11,13 +11,13 @@ contains function psb_c_cgeall(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -40,13 +40,13 @@ contains function psb_c_cgeasb(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -70,13 +70,13 @@ contains function psb_c_cgefree(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -102,16 +102,16 @@ contains function psb_c_cgeins(nz,irw,val,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*) complex(c_float_complex) :: val(*) type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: ixb, info + integer(psb_c_ipk) :: ixb, info res = -1 if (c_associated(cdh%item)) then @@ -143,16 +143,16 @@ contains function psb_c_cgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*) complex(c_float_complex) :: val(*) type(psb_c_cvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp - integer :: ixb, info + integer(psb_c_ipk) :: ixb, info res = -1 if (c_associated(cdh%item)) then @@ -183,13 +183,13 @@ contains function psb_c_cspall(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -213,13 +213,13 @@ contains function psb_c_cspasb(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -242,13 +242,13 @@ contains function psb_c_cspfree(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -277,10 +277,10 @@ contains use psb_c_rsb_mat_mod #endif implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: cdh, mh,upd,dupl + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) - integer :: info,n, fdupl + integer(psb_c_ipk) :: info,n, fdupl character(len=5) :: fafmt #ifdef HAVE_LIBRSB type(psb_c_rsb_sparse_mat) :: arsb @@ -313,16 +313,16 @@ contains function psb_c_cspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*), icl(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*), icl(*) complex(c_float_complex) :: val(*) type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap - integer :: ixb,info,n + integer(psb_c_ipk) :: ixb,info,n res = -1 if (c_associated(cdh%item)) then @@ -350,14 +350,14 @@ contains function psb_c_csprn(mh,cdh,clear) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res logical(c_bool), value :: clear type(psb_c_cspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info logical :: fclear res = -1 @@ -382,9 +382,9 @@ contains !!$ function psb_c_cspprint(mh) bind(c) result(res) !!$ !!$ implicit none -!!$ integer(psb_c_int) :: res -!!$ integer(psb_c_int), value :: mh -!!$ integer :: info +!!$ integer(psb_c_ipk) :: res +!!$ integer(psb_c_ipk), value :: mh +!!$ integer(psb_c_ipk) :: info !!$ !!$ !!$ res = -1 diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index 7f13f9cee..f61f64cf8 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -18,14 +18,14 @@ typedef struct PSB_C_ZSPMAT { /* dense vectors */ psb_c_zvector* psb_c_new_zvector(); psb_i_t psb_c_zvect_get_nrows(psb_c_zvector *xh); -psb_z_t *psb_c_zvect_get_cpy( psb_c_zvector *xh); +psb_z_t *psb_c_zvect_get_cpy( psb_c_zvector *xh); psb_i_t psb_c_zvect_f_get_cpy(psb_z_t *v, psb_c_zvector *xh); psb_i_t psb_c_zvect_zero(psb_c_zvector *xh); psb_i_t psb_c_zgeall(psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeins(psb_i_t nz, const psb_i_t *irw, const psb_z_t *val, +psb_i_t psb_c_zgeins(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val, psb_c_zvector *xh, psb_c_descriptor *cdh); -psb_i_t psb_c_zgeins_add(psb_i_t nz, const psb_i_t *irw, const psb_z_t *val, +psb_i_t psb_c_zgeins_add(psb_i_t nz, const psb_l_t *irw, const psb_z_t *val, psb_c_zvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_zgeasb(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_zgefree(psb_c_zvector *xh, psb_c_descriptor *cdh); @@ -35,8 +35,8 @@ psb_c_zspmat* psb_c_new_zspmat(); psb_i_t psb_c_zspall(psb_c_zspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_zspasb(psb_c_zspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_zspfree(psb_c_zspmat *mh, psb_c_descriptor *cdh); -psb_i_t psb_c_zspins(psb_i_t nz, const psb_i_t *irw, const psb_i_t *icl, const psb_z_t *val, - psb_c_zspmat *mh, psb_c_descriptor *cdh); +psb_i_t psb_c_zspins(psb_i_t nz, const psb_l_t *irw, const psb_l_t *icl, + const psb_z_t *val, psb_c_zspmat *mh, psb_c_descriptor *cdh); psb_i_t psb_c_zmat_get_nrows(psb_c_zspmat *mh); psb_i_t psb_c_zmat_get_ncols(psb_c_zspmat *mh); diff --git a/cbind/base/psb_c_zcomm.c b/cbind/base/psb_c_zcomm.c index 7a47d667b..1f6607cc4 100644 --- a/cbind/base/psb_c_zcomm.c +++ b/cbind/base/psb_c_zcomm.c @@ -6,7 +6,7 @@ psb_z_t* psb_c_zvgather(psb_c_zvector *xh, psb_c_descriptor *cdh) { psb_z_t *temp=NULL; - psb_i_t vsize=0; + psb_l_t vsize=0; if ((vsize=psb_c_cd_get_global_rows(cdh))<0) return(temp); diff --git a/cbind/base/psb_c_zcomm.h b/cbind/base/psb_c_zcomm.h index 8cf9e4369..8b7ca7e08 100644 --- a/cbind/base/psb_c_zcomm.h +++ b/cbind/base/psb_c_zcomm.h @@ -12,7 +12,7 @@ extern "C" { psb_i_t psb_c_zovrl(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_zovrl_opt(psb_c_zvector *xh, psb_c_descriptor *cdh, psb_i_t update, psb_i_t mode); - psb_i_t psb_c_zvscatter(psb_i_t ng, psb_z_t *gx, psb_c_zvector *xh, psb_c_descriptor *cdh); + psb_i_t psb_c_zvscatter(psb_l_t ng, psb_z_t *gx, psb_c_zvector *xh, psb_c_descriptor *cdh); psb_z_t* psb_c_zvgather(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_c_zspmat* psb_c_zspgather(psb_c_zspmat *ah, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_cpenv_mod.f90 b/cbind/base/psb_cpenv_mod.f90 index cf5fc7b0b..b58d663ca 100644 --- a/cbind/base/psb_cpenv_mod.f90 +++ b/cbind/base/psb_cpenv_mod.f90 @@ -9,14 +9,14 @@ contains function psb_c_get_index_base() bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res res = psb_c_index_base end function psb_c_get_index_base subroutine psb_c_set_index_base(base) bind(c) implicit none - integer(psb_c_int), value :: base + integer(psb_c_ipk), value :: base psb_c_index_base = base end subroutine psb_c_set_index_base @@ -25,7 +25,7 @@ contains use psb_base_mod, only : psb_get_errstatus implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res res = psb_get_errstatus() end function psb_c_get_errstatus @@ -34,7 +34,7 @@ contains use psb_base_mod, only : psb_init implicit none - integer(psb_c_int) :: psb_c_init + integer(psb_c_ipk) :: psb_c_init integer :: ictxt @@ -44,7 +44,7 @@ contains subroutine psb_c_exit_ctxt(ictxt) bind(c) use psb_base_mod, only : psb_exit - integer(psb_c_int), value :: ictxt + integer(psb_c_ipk), value :: ictxt call psb_exit(ictxt,close=.false.) return @@ -52,7 +52,7 @@ contains subroutine psb_c_exit(ictxt) bind(c) use psb_base_mod, only : psb_exit - integer(psb_c_int), value :: ictxt + integer(psb_c_ipk), value :: ictxt call psb_exit(ictxt) return @@ -60,7 +60,7 @@ contains subroutine psb_c_abort(ictxt) bind(c) use psb_base_mod, only : psb_abort - integer(psb_c_int), value :: ictxt + integer(psb_c_ipk), value :: ictxt call psb_abort(ictxt) return @@ -69,8 +69,8 @@ contains subroutine psb_c_info(ictxt,iam,np) bind(c) use psb_base_mod, only : psb_info - integer(psb_c_int), value :: ictxt - integer(psb_c_int) :: iam,np + integer(psb_c_ipk), value :: ictxt + integer(psb_c_ipk) :: iam,np call psb_info(ictxt,iam,np) return @@ -78,7 +78,7 @@ contains subroutine psb_c_barrier(ictxt) bind(c) use psb_base_mod, only : psb_barrier - integer(psb_c_int), value :: ictxt + integer(psb_c_ipk), value :: ictxt call psb_barrier(ictxt) end subroutine psb_c_barrier @@ -89,11 +89,26 @@ contains psb_c_wtime = psb_wtime() end function psb_c_wtime + subroutine psb_c_mbcast(ictxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast + implicit none + integer(psb_c_ipk), value :: ictxt,n, root + integer(psb_c_mpk) :: v(*) + + if (n < 0) then + write(0,*) 'Wrong size in BCAST' + return + end if + if (n==0) return + + call psb_bcast(ictxt,v(1:n),root=root) + end subroutine psb_c_mbcast + subroutine psb_c_ibcast(ictxt,n,v,root) bind(c) use psb_base_mod, only : psb_bcast implicit none - integer(psb_c_int), value :: ictxt,n, root - integer(psb_c_int) :: v(*) + integer(psb_c_ipk), value :: ictxt,n, root + integer(psb_c_ipk) :: v(*) if (n < 0) then write(0,*) 'Wrong size in BCAST' @@ -104,10 +119,40 @@ contains call psb_bcast(ictxt,v(1:n),root=root) end subroutine psb_c_ibcast + subroutine psb_c_lbcast(ictxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast + implicit none + integer(psb_c_ipk), value :: ictxt,n, root + integer(psb_c_lpk) :: v(*) + + if (n < 0) then + write(0,*) 'Wrong size in BCAST' + return + end if + if (n==0) return + + call psb_bcast(ictxt,v(1:n),root=root) + end subroutine psb_c_lbcast + + subroutine psb_c_ebcast(ictxt,n,v,root) bind(c) + use psb_base_mod, only : psb_bcast + implicit none + integer(psb_c_ipk), value :: ictxt,n, root + integer(psb_c_epk) :: v(*) + + if (n < 0) then + write(0,*) 'Wrong size in BCAST' + return + end if + if (n==0) return + + call psb_bcast(ictxt,v(1:n),root=root) + end subroutine psb_c_ebcast + subroutine psb_c_sbcast(ictxt,n,v,root) bind(c) use psb_base_mod implicit none - integer(psb_c_int), value :: ictxt,n, root + integer(psb_c_ipk), value :: ictxt,n, root real(c_float) :: v(*) if (n < 0) then @@ -122,7 +167,7 @@ contains subroutine psb_c_dbcast(ictxt,n,v,root) bind(c) use psb_base_mod, only : psb_bcast implicit none - integer(psb_c_int), value :: ictxt,n, root + integer(psb_c_ipk), value :: ictxt,n, root real(c_double) :: v(*) if (n < 0) then @@ -138,7 +183,7 @@ contains subroutine psb_c_cbcast(ictxt,n,v,root) bind(c) use psb_base_mod, only : psb_bcast implicit none - integer(psb_c_int), value :: ictxt,n, root + integer(psb_c_ipk), value :: ictxt,n, root complex(c_float_complex) :: v(*) if (n < 0) then @@ -153,7 +198,7 @@ contains subroutine psb_c_zbcast(ictxt,n,v,root) bind(c) use psb_base_mod implicit none - integer(psb_c_int), value :: ictxt,n, root + integer(psb_c_ipk), value :: ictxt,n, root complex(c_double_complex) :: v(*) if (n < 0) then @@ -166,11 +211,11 @@ contains end subroutine psb_c_zbcast subroutine psb_c_hbcast(ictxt,v,root) bind(c) - use psb_base_mod, only : psb_bcast, psb_info + use psb_base_mod, only : psb_bcast, psb_info, psb_ipk_ implicit none - integer(psb_c_int), value :: ictxt, root - character(c_char) :: v(*) - integer :: n, iam, np + integer(psb_c_ipk), value :: ictxt, root + character(c_char) :: v(*) + integer(psb_ipk_) :: iam, np, n call psb_info(ictxt,iam,np) @@ -190,8 +235,8 @@ contains use psb_base_string_cbind_mod implicit none character(c_char), intent(inout) :: cmesg(*) - integer(psb_c_int), intent(in), value :: len - integer(psb_c_int) :: res + integer(psb_c_ipk), intent(in), value :: len + integer(psb_c_ipk) :: res character(len=psb_max_errmsg_len_), allocatable :: fmesg(:) character(len=psb_max_errmsg_len_) :: tmp integer :: i, j, ll, il diff --git a/cbind/base/psb_d_comm_cbind_mod.f90 b/cbind/base/psb_d_comm_cbind_mod.f90 index 857d0ce7e..c82e98d42 100644 --- a/cbind/base/psb_d_comm_cbind_mod.f90 +++ b/cbind/base/psb_d_comm_cbind_mod.f90 @@ -8,14 +8,14 @@ contains function psb_c_d_ovrl(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -39,15 +39,15 @@ contains function psb_c_d_ovrl_opt(xh,cdh,update,mode) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: update, mode + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: update, mode type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -72,14 +72,14 @@ contains function psb_c_d_halo(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -103,8 +103,8 @@ contains function psb_c_d_halo_opt(xh,cdh,tran,data,mode) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: data, mode + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: data, mode character(c_char) :: tran @@ -114,7 +114,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp character :: ftran - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -141,8 +141,8 @@ contains function psb_c_d_vscatter(ng,gx,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: ng + integer(psb_c_ipk) :: res + integer(psb_c_lpk), value :: ng real(c_double), target :: gx(*) type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh @@ -150,7 +150,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: vp real(psb_dpk_), pointer :: pgx(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -175,7 +175,7 @@ contains function psb_c_dvgather(v,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res real(c_double), target :: v(*) type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh @@ -183,7 +183,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: vp real(psb_dpk_), allocatable :: fv(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -208,13 +208,13 @@ contains function psb_c_dspgather(gah,ah,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: ah, gah type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap, gap - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 index 76bdfb183..1d3ec8597 100644 --- a/cbind/base/psb_d_psblas_cbind_mod.f90 +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -1,14 +1,14 @@ module psb_d_psblas_cbind_mod use iso_c_binding + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod contains function psb_c_dgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dvector) :: xh,yh type(psb_c_descriptor) :: cdh @@ -16,7 +16,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp,yp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -44,9 +44,6 @@ contains end function psb_c_dgeaxpby function psb_c_dgenrm2(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double) :: res @@ -54,7 +51,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 @@ -74,9 +71,6 @@ contains end function psb_c_dgenrm2 function psb_c_dgeamax(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double) :: res @@ -84,7 +78,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -103,9 +97,6 @@ contains end function psb_c_dgeamax function psb_c_dgeasum(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double) :: res @@ -113,7 +104,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 @@ -134,9 +125,6 @@ contains function psb_c_dspnrmi(ah,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double) :: res @@ -144,7 +132,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -163,9 +151,6 @@ contains end function psb_c_dspnrmi function psb_c_dgedot(xh,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double) :: res @@ -173,7 +158,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp,yp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -197,11 +182,8 @@ contains function psb_c_dspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: ah type(psb_c_dvector) :: xh,yh @@ -210,7 +192,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp,yp type(psb_dspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -242,11 +224,8 @@ contains function psb_c_dspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: ah type(psb_c_dvector) :: xh,yh @@ -260,7 +239,7 @@ contains type(psb_dspmat_type), pointer :: ap character :: ftrans logical :: fdoswap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -294,11 +273,8 @@ contains function psb_c_dspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: ah type(psb_c_dvector) :: xh,yh @@ -307,7 +283,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp,yp type(psb_dspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index 483142058..a727d654b 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -11,11 +11,11 @@ contains function psb_c_dvect_get_nrows(xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dvector) :: xh type(psb_d_vect_type), pointer :: vp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -29,23 +29,21 @@ contains function psb_c_dvect_f_get_cpy(v,xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res real(c_double) :: v(*) type(psb_c_dvector) :: xh type(psb_d_vect_type), pointer :: vp real(psb_dpk_), allocatable :: fv(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 - if (c_associated(xh%item)) then - res = 0 + if (c_associated(xh%item)) then call c_f_pointer(xh%item,vp) fv = vp%get_vect() sz = size(fv) v(1:sz) = fv(1:sz) - write(0,*) 'In dvect_f_get_cpy:',v(1),fv(1) end if end function psb_c_dvect_f_get_cpy @@ -54,11 +52,11 @@ contains function psb_c_dvect_zero(xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dvector) :: xh type(psb_d_vect_type), pointer :: vp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -75,11 +73,11 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: mh type(psb_dspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = 0 if (c_associated(mh%item)) then @@ -98,11 +96,11 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: mh type(psb_dspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = 0 if (c_associated(mh%item)) then @@ -121,12 +119,12 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res character(c_char) :: name(*) type(psb_c_dspmat) :: mh type(psb_dspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info character(1024) :: fname res = 0 diff --git a/cbind/base/psb_d_tools_cbind_mod.F90 b/cbind/base/psb_d_tools_cbind_mod.F90 index d39c040b4..0a898196f 100644 --- a/cbind/base/psb_d_tools_cbind_mod.F90 +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -11,13 +11,13 @@ contains function psb_c_dgeall(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -40,13 +40,13 @@ contains function psb_c_dgeasb(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -70,13 +70,13 @@ contains function psb_c_dgefree(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -102,16 +102,16 @@ contains function psb_c_dgeins(nz,irw,val,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*) real(c_double) :: val(*) type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: ixb, info + integer(psb_c_ipk) :: ixb, info res = -1 if (c_associated(cdh%item)) then @@ -143,16 +143,16 @@ contains function psb_c_dgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*) real(c_double) :: val(*) type(psb_c_dvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp - integer :: ixb, info + integer(psb_c_ipk) :: ixb, info res = -1 if (c_associated(cdh%item)) then @@ -183,13 +183,13 @@ contains function psb_c_dspall(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -213,13 +213,13 @@ contains function psb_c_dspasb(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -242,13 +242,13 @@ contains function psb_c_dspfree(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -277,10 +277,10 @@ contains use psb_d_rsb_mat_mod #endif implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: cdh, mh,upd,dupl + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) - integer :: info,n, fdupl + integer(psb_c_ipk) :: info,n, fdupl character(len=5) :: fafmt #ifdef HAVE_LIBRSB type(psb_d_rsb_sparse_mat) :: arsb @@ -313,16 +313,16 @@ contains function psb_c_dspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*), icl(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*), icl(*) real(c_double) :: val(*) type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap - integer :: ixb,info,n + integer(psb_c_ipk) :: ixb,info,n res = -1 if (c_associated(cdh%item)) then @@ -350,14 +350,14 @@ contains function psb_c_dsprn(mh,cdh,clear) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res logical(c_bool), value :: clear type(psb_c_dspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info logical :: fclear res = -1 @@ -382,9 +382,9 @@ contains !!$ function psb_c_dspprint(mh) bind(c) result(res) !!$ !!$ implicit none -!!$ integer(psb_c_int) :: res -!!$ integer(psb_c_int), value :: mh -!!$ integer :: info +!!$ integer(psb_c_ipk) :: res +!!$ integer(psb_c_ipk), value :: mh +!!$ integer(psb_c_ipk) :: info !!$ !!$ !!$ res = -1 diff --git a/cbind/base/psb_objhandle_mod.F90 b/cbind/base/psb_objhandle_mod.F90 index b2f1c0089..e7cb8aeb3 100644 --- a/cbind/base/psb_objhandle_mod.F90 +++ b/cbind/base/psb_objhandle_mod.F90 @@ -1,12 +1,7 @@ module psb_objhandle_mod use iso_c_binding - -#if defined(LONG_INTEGERS) - integer, parameter :: psb_c_int = c_int64_t -#else - integer, parameter :: psb_c_int = c_int32_t -#endif - + use psb_cbind_const_mod + type, bind(c) :: psb_c_object_type type(c_ptr) :: item = c_null_ptr end type psb_c_object_type diff --git a/cbind/base/psb_s_comm_cbind_mod.f90 b/cbind/base/psb_s_comm_cbind_mod.f90 index 71e68cc5b..378839344 100644 --- a/cbind/base/psb_s_comm_cbind_mod.f90 +++ b/cbind/base/psb_s_comm_cbind_mod.f90 @@ -8,14 +8,14 @@ contains function psb_c_s_ovrl(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -39,15 +39,15 @@ contains function psb_c_s_ovrl_opt(xh,cdh,update,mode) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: update, mode + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: update, mode type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -72,14 +72,14 @@ contains function psb_c_s_halo(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -103,8 +103,8 @@ contains function psb_c_s_halo_opt(xh,cdh,tran,data,mode) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: data, mode + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: data, mode character(c_char) :: tran @@ -114,7 +114,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp character :: ftran - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -141,8 +141,8 @@ contains function psb_c_s_vscatter(ng,gx,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: ng + integer(psb_c_ipk) :: res + integer(psb_c_lpk), value :: ng real(c_float), target :: gx(*) type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh @@ -150,7 +150,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: vp real(psb_spk_), pointer :: pgx(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -175,7 +175,7 @@ contains function psb_c_svgather(v,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res real(c_float), target :: v(*) type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh @@ -183,7 +183,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: vp real(psb_spk_), allocatable :: fv(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -208,13 +208,13 @@ contains function psb_c_sspgather(gah,ah,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: ah, gah type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap, gap - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/base/psb_s_psblas_cbind_mod.f90 b/cbind/base/psb_s_psblas_cbind_mod.f90 index ea964ea75..5a0090027 100644 --- a/cbind/base/psb_s_psblas_cbind_mod.f90 +++ b/cbind/base/psb_s_psblas_cbind_mod.f90 @@ -1,14 +1,14 @@ module psb_s_psblas_cbind_mod use iso_c_binding + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod contains function psb_c_sgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_svector) :: xh,yh type(psb_c_descriptor) :: cdh @@ -16,7 +16,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp,yp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -44,9 +44,6 @@ contains end function psb_c_sgeaxpby function psb_c_sgenrm2(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float) :: res @@ -54,7 +51,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 @@ -74,9 +71,6 @@ contains end function psb_c_sgenrm2 function psb_c_sgeamax(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float) :: res @@ -84,7 +78,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -103,9 +97,6 @@ contains end function psb_c_sgeamax function psb_c_sgeasum(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float) :: res @@ -113,7 +104,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 @@ -134,9 +125,6 @@ contains function psb_c_sspnrmi(ah,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float) :: res @@ -144,7 +132,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -163,9 +151,6 @@ contains end function psb_c_sspnrmi function psb_c_sgedot(xh,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_float) :: res @@ -173,7 +158,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp,yp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -197,11 +182,8 @@ contains function psb_c_sspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: ah type(psb_c_svector) :: xh,yh @@ -210,7 +192,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp,yp type(psb_sspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -242,11 +224,8 @@ contains function psb_c_sspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: ah type(psb_c_svector) :: xh,yh @@ -260,7 +239,7 @@ contains type(psb_sspmat_type), pointer :: ap character :: ftrans logical :: fdoswap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -294,11 +273,8 @@ contains function psb_c_sspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: ah type(psb_c_svector) :: xh,yh @@ -307,7 +283,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp,yp type(psb_sspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/base/psb_s_serial_cbind_mod.F90 b/cbind/base/psb_s_serial_cbind_mod.F90 index dedaab92c..7113e5c26 100644 --- a/cbind/base/psb_s_serial_cbind_mod.F90 +++ b/cbind/base/psb_s_serial_cbind_mod.F90 @@ -11,11 +11,11 @@ contains function psb_c_svect_get_nrows(xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_svector) :: xh type(psb_s_vect_type), pointer :: vp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -29,13 +29,13 @@ contains function psb_c_svect_f_get_cpy(v,xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res real(c_float) :: v(*) type(psb_c_svector) :: xh type(psb_s_vect_type), pointer :: vp real(psb_spk_), allocatable :: fv(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -52,11 +52,11 @@ contains function psb_c_svect_zero(xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_svector) :: xh type(psb_s_vect_type), pointer :: vp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -73,11 +73,11 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: mh type(psb_sspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = 0 if (c_associated(mh%item)) then @@ -96,11 +96,11 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: mh type(psb_sspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = 0 if (c_associated(mh%item)) then @@ -119,12 +119,12 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res character(c_char) :: name(*) type(psb_c_sspmat) :: mh type(psb_sspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info character(1024) :: fname res = 0 diff --git a/cbind/base/psb_s_tools_cbind_mod.F90 b/cbind/base/psb_s_tools_cbind_mod.F90 index 117b62579..40b82de65 100644 --- a/cbind/base/psb_s_tools_cbind_mod.F90 +++ b/cbind/base/psb_s_tools_cbind_mod.F90 @@ -11,13 +11,13 @@ contains function psb_c_sgeall(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -40,13 +40,13 @@ contains function psb_c_sgeasb(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -70,13 +70,13 @@ contains function psb_c_sgefree(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -102,16 +102,16 @@ contains function psb_c_sgeins(nz,irw,val,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*) real(c_float) :: val(*) type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: ixb, info + integer(psb_c_ipk) :: ixb, info res = -1 if (c_associated(cdh%item)) then @@ -143,16 +143,16 @@ contains function psb_c_sgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*) real(c_float) :: val(*) type(psb_c_svector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp - integer :: ixb, info + integer(psb_c_ipk) :: ixb, info res = -1 if (c_associated(cdh%item)) then @@ -183,13 +183,13 @@ contains function psb_c_sspall(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -213,13 +213,13 @@ contains function psb_c_sspasb(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -242,13 +242,13 @@ contains function psb_c_sspfree(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -277,10 +277,10 @@ contains use psb_s_rsb_mat_mod #endif implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: cdh, mh,upd,dupl + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) - integer :: info,n, fdupl + integer(psb_c_ipk) :: info,n, fdupl character(len=5) :: fafmt #ifdef HAVE_LIBRSB type(psb_s_rsb_sparse_mat) :: arsb @@ -313,16 +313,16 @@ contains function psb_c_sspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*), icl(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*), icl(*) real(c_float) :: val(*) type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap - integer :: ixb,info,n + integer(psb_c_ipk) :: ixb,info,n res = -1 if (c_associated(cdh%item)) then @@ -350,14 +350,14 @@ contains function psb_c_ssprn(mh,cdh,clear) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res logical(c_bool), value :: clear type(psb_c_sspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info logical :: fclear res = -1 @@ -382,9 +382,9 @@ contains !!$ function psb_c_sspprint(mh) bind(c) result(res) !!$ !!$ implicit none -!!$ integer(psb_c_int) :: res -!!$ integer(psb_c_int), value :: mh -!!$ integer :: info +!!$ integer(psb_c_ipk) :: res +!!$ integer(psb_c_ipk), value :: mh +!!$ integer(psb_c_ipk) :: info !!$ !!$ !!$ res = -1 diff --git a/cbind/base/psb_z_comm_cbind_mod.f90 b/cbind/base/psb_z_comm_cbind_mod.f90 index 865e56eee..8e80d257e 100644 --- a/cbind/base/psb_z_comm_cbind_mod.f90 +++ b/cbind/base/psb_z_comm_cbind_mod.f90 @@ -8,14 +8,14 @@ contains function psb_c_z_ovrl(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -39,15 +39,15 @@ contains function psb_c_z_ovrl_opt(xh,cdh,update,mode) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: update, mode + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: update, mode type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -72,14 +72,14 @@ contains function psb_c_z_halo(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -103,8 +103,8 @@ contains function psb_c_z_halo_opt(xh,cdh,tran,data,mode) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: data, mode + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: data, mode character(c_char) :: tran @@ -114,7 +114,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp character :: ftran - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -141,8 +141,8 @@ contains function psb_c_z_vscatter(ng,gx,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: ng + integer(psb_c_ipk) :: res + integer(psb_c_lpk), value :: ng complex(c_double_complex), target :: gx(*) type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh @@ -150,7 +150,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: vp complex(psb_dpk_), pointer :: pgx(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -175,7 +175,7 @@ contains function psb_c_zvgather(v,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res complex(c_double_complex), target :: v(*) type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh @@ -183,7 +183,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: vp complex(psb_dpk_), allocatable :: fv(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -208,13 +208,13 @@ contains function psb_c_zspgather(gah,ah,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: ah, gah type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap, gap - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/base/psb_z_psblas_cbind_mod.f90 b/cbind/base/psb_z_psblas_cbind_mod.f90 index 0a3cad537..879fd4ff5 100644 --- a/cbind/base/psb_z_psblas_cbind_mod.f90 +++ b/cbind/base/psb_z_psblas_cbind_mod.f90 @@ -1,14 +1,14 @@ module psb_z_psblas_cbind_mod use iso_c_binding + use psb_base_mod + use psb_objhandle_mod + use psb_base_string_cbind_mod contains function psb_c_zgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zvector) :: xh,yh type(psb_c_descriptor) :: cdh @@ -16,7 +16,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp,yp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -44,9 +44,6 @@ contains end function psb_c_zgeaxpby function psb_c_zgenrm2(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double_complex) :: res @@ -54,7 +51,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 @@ -74,9 +71,6 @@ contains end function psb_c_zgenrm2 function psb_c_zgeamax(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double_complex) :: res @@ -84,7 +78,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -103,9 +97,6 @@ contains end function psb_c_zgeamax function psb_c_zgeasum(xh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double_complex) :: res @@ -113,7 +104,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 @@ -134,9 +125,6 @@ contains function psb_c_zspnrmi(ah,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none real(c_double_complex) :: res @@ -144,7 +132,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -163,9 +151,6 @@ contains end function psb_c_zspnrmi function psb_c_zgedot(xh,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none complex(c_double_complex) :: res @@ -173,7 +158,7 @@ contains type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp,yp - integer :: info + integer(psb_c_ipk) :: info res = -1.0 if (c_associated(cdh%item)) then @@ -197,11 +182,8 @@ contains function psb_c_zspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: ah type(psb_c_zvector) :: xh,yh @@ -210,7 +192,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp,yp type(psb_zspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -242,11 +224,8 @@ contains function psb_c_zspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: ah type(psb_c_zvector) :: xh,yh @@ -260,7 +239,7 @@ contains type(psb_zspmat_type), pointer :: ap character :: ftrans logical :: fdoswap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then @@ -294,11 +273,8 @@ contains function psb_c_zspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: ah type(psb_c_zvector) :: xh,yh @@ -307,7 +283,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp,yp type(psb_zspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/base/psb_z_serial_cbind_mod.F90 b/cbind/base/psb_z_serial_cbind_mod.F90 index b2a3d206b..4c279f347 100644 --- a/cbind/base/psb_z_serial_cbind_mod.F90 +++ b/cbind/base/psb_z_serial_cbind_mod.F90 @@ -11,11 +11,11 @@ contains function psb_c_zvect_get_nrows(xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zvector) :: xh type(psb_z_vect_type), pointer :: vp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -29,13 +29,13 @@ contains function psb_c_zvect_f_get_cpy(v,xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res complex(c_double_complex) :: v(*) type(psb_c_zvector) :: xh type(psb_z_vect_type), pointer :: vp complex(psb_dpk_), allocatable :: fv(:) - integer :: info, sz + integer(psb_c_ipk) :: info, sz res = -1 @@ -52,11 +52,11 @@ contains function psb_c_zvect_zero(xh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zvector) :: xh type(psb_z_vect_type), pointer :: vp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -73,11 +73,11 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: mh type(psb_zspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = 0 if (c_associated(mh%item)) then @@ -96,11 +96,11 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: mh type(psb_zspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info res = 0 if (c_associated(mh%item)) then @@ -119,12 +119,12 @@ contains use psb_objhandle_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res character(c_char) :: name(*) type(psb_c_zspmat) :: mh type(psb_zspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info character(1024) :: fname res = 0 diff --git a/cbind/base/psb_z_tools_cbind_mod.F90 b/cbind/base/psb_z_tools_cbind_mod.F90 index 4d293faba..9501d20d1 100644 --- a/cbind/base/psb_z_tools_cbind_mod.F90 +++ b/cbind/base/psb_z_tools_cbind_mod.F90 @@ -11,13 +11,13 @@ contains function psb_c_zgeall(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -40,13 +40,13 @@ contains function psb_c_zgeasb(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -70,13 +70,13 @@ contains function psb_c_zgefree(xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: info + integer(psb_c_ipk) :: info res = -1 @@ -102,16 +102,16 @@ contains function psb_c_zgeins(nz,irw,val,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*) complex(c_double_complex) :: val(*) type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: ixb, info + integer(psb_c_ipk) :: ixb, info res = -1 if (c_associated(cdh%item)) then @@ -143,16 +143,16 @@ contains function psb_c_zgeins_add(nz,irw,val,xh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*) complex(c_double_complex) :: val(*) type(psb_c_zvector) :: xh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp - integer :: ixb, info + integer(psb_c_ipk) :: ixb, info res = -1 if (c_associated(cdh%item)) then @@ -183,13 +183,13 @@ contains function psb_c_zspall(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -213,13 +213,13 @@ contains function psb_c_zspasb(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -242,13 +242,13 @@ contains function psb_c_zspfree(mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap - integer :: info,n + integer(psb_c_ipk) :: info,n res = -1 if (c_associated(cdh%item)) then @@ -277,10 +277,10 @@ contains use psb_z_rsb_mat_mod #endif implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: cdh, mh,upd,dupl + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: cdh, mh,upd,dupl character(c_char) :: afmt(*) - integer :: info,n, fdupl + integer(psb_c_ipk) :: info,n, fdupl character(len=5) :: fafmt #ifdef HAVE_LIBRSB type(psb_z_rsb_sparse_mat) :: arsb @@ -313,16 +313,16 @@ contains function psb_c_zspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) implicit none - integer(psb_c_int) :: res - integer(psb_c_int), value :: nz - integer(psb_c_int) :: irw(*), icl(*) + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: nz + integer(psb_c_lpk) :: irw(*), icl(*) complex(c_double_complex) :: val(*) type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap - integer :: ixb,info,n + integer(psb_c_ipk) :: ixb,info,n res = -1 if (c_associated(cdh%item)) then @@ -350,14 +350,14 @@ contains function psb_c_zsprn(mh,cdh,clear) bind(c) result(res) implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res logical(c_bool), value :: clear type(psb_c_zspmat) :: mh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap - integer :: info + integer(psb_c_ipk) :: info logical :: fclear res = -1 @@ -382,9 +382,9 @@ contains !!$ function psb_c_zspprint(mh) bind(c) result(res) !!$ !!$ implicit none -!!$ integer(psb_c_int) :: res -!!$ integer(psb_c_int), value :: mh -!!$ integer :: info +!!$ integer(psb_c_ipk) :: res +!!$ integer(psb_c_ipk), value :: mh +!!$ integer(psb_c_ipk) :: info !!$ !!$ !!$ res = -1 diff --git a/cbind/krylov/psb_base_krylov_cbind_mod.f90 b/cbind/krylov/psb_base_krylov_cbind_mod.f90 index 5f322fbcf..8662ba92e 100644 --- a/cbind/krylov/psb_base_krylov_cbind_mod.f90 +++ b/cbind/krylov/psb_base_krylov_cbind_mod.f90 @@ -1,8 +1,10 @@ module psb_base_krylov_cbind_mod use iso_c_binding + use psb_objhandle_mod + type, bind(c) :: solveroptions - integer(c_int) :: iter, itmax, itrace, irst, istop + integer(psb_c_ipk) :: iter, itmax, itrace, irst, istop real(c_double) :: eps, err end type solveroptions @@ -12,7 +14,7 @@ contains & bind(c,name='psb_c_DefaultSolverOptions') result(res) implicit none type(solveroptions) :: options - integer(c_int) :: res + integer(psb_c_ipk) :: res options%itmax = 1000 options%itrace = 0 diff --git a/cbind/krylov/psb_ckrylov_cbind_mod.f90 b/cbind/krylov/psb_ckrylov_cbind_mod.f90 index 1e63c4287..6ed23f651 100644 --- a/cbind/krylov/psb_ckrylov_cbind_mod.f90 +++ b/cbind/krylov/psb_ckrylov_cbind_mod.f90 @@ -13,11 +13,11 @@ contains use psb_prec_cbind_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: ah type(psb_c_descriptor) :: cdh - type(psb_c_cprec) :: ph - type(psb_c_cvector) :: bh,xh + type(psb_c_cprec) :: ph + type(psb_c_cvector) :: bh,xh character(c_char) :: methd(*) type(solveroptions) :: options @@ -38,14 +38,14 @@ contains use psb_prec_cbind_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: ah type(psb_c_descriptor) :: cdh type(psb_c_cprec) :: ph type(psb_c_cvector) :: bh,xh - integer(psb_c_int), value :: itmax,itrace,irst,istop + integer(psb_c_ipk), value :: itmax,itrace,irst,istop real(c_double), value :: eps - integer(psb_c_int) :: iter + integer(psb_c_ipk) :: iter real(c_double) :: err character(c_char) :: methd(*) type(solveroptions) :: options @@ -54,9 +54,9 @@ contains type(psb_cprec_type), pointer :: precp type(psb_c_vect_type), pointer :: xp, bp - integer :: info,fitmax,fitrace,first,fistop,fiter - character(len=20) :: fmethd - real(psb_spk_) :: feps,ferr + integer(psb_c_ipk) :: info,fitmax,fitrace,first,fistop,fiter + character(len=20) :: fmethd + real(psb_spk_) :: feps,ferr res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/krylov/psb_dkrylov_cbind_mod.f90 b/cbind/krylov/psb_dkrylov_cbind_mod.f90 index ce97f4e65..a9a1b3ed9 100644 --- a/cbind/krylov/psb_dkrylov_cbind_mod.f90 +++ b/cbind/krylov/psb_dkrylov_cbind_mod.f90 @@ -13,11 +13,11 @@ contains use psb_prec_cbind_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: ah type(psb_c_descriptor) :: cdh - type(psb_c_dprec) :: ph - type(psb_c_dvector) :: bh,xh + type(psb_c_dprec) :: ph + type(psb_c_dvector) :: bh,xh character(c_char) :: methd(*) type(solveroptions) :: options @@ -38,14 +38,14 @@ contains use psb_prec_cbind_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: ah type(psb_c_descriptor) :: cdh type(psb_c_dprec) :: ph type(psb_c_dvector) :: bh,xh - integer(psb_c_int), value :: itmax,itrace,irst,istop + integer(psb_c_ipk), value :: itmax,itrace,irst,istop real(c_double), value :: eps - integer(psb_c_int) :: iter + integer(psb_c_ipk) :: iter real(c_double) :: err character(c_char) :: methd(*) type(solveroptions) :: options @@ -54,9 +54,9 @@ contains type(psb_dprec_type), pointer :: precp type(psb_d_vect_type), pointer :: xp, bp - integer :: info,fitmax,fitrace,first,fistop,fiter - character(len=20) :: fmethd - real(psb_dpk_) :: feps,ferr + integer(psb_c_ipk) :: info,fitmax,fitrace,first,fistop,fiter + character(len=20) :: fmethd + real(psb_dpk_) :: feps,ferr res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/krylov/psb_skrylov_cbind_mod.f90 b/cbind/krylov/psb_skrylov_cbind_mod.f90 index da0c734c9..5e3815515 100644 --- a/cbind/krylov/psb_skrylov_cbind_mod.f90 +++ b/cbind/krylov/psb_skrylov_cbind_mod.f90 @@ -13,11 +13,11 @@ contains use psb_prec_cbind_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: ah type(psb_c_descriptor) :: cdh - type(psb_c_sprec) :: ph - type(psb_c_svector) :: bh,xh + type(psb_c_sprec) :: ph + type(psb_c_svector) :: bh,xh character(c_char) :: methd(*) type(solveroptions) :: options @@ -38,14 +38,14 @@ contains use psb_prec_cbind_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: ah type(psb_c_descriptor) :: cdh type(psb_c_sprec) :: ph type(psb_c_svector) :: bh,xh - integer(psb_c_int), value :: itmax,itrace,irst,istop + integer(psb_c_ipk), value :: itmax,itrace,irst,istop real(c_double), value :: eps - integer(psb_c_int) :: iter + integer(psb_c_ipk) :: iter real(c_double) :: err character(c_char) :: methd(*) type(solveroptions) :: options @@ -54,9 +54,9 @@ contains type(psb_sprec_type), pointer :: precp type(psb_s_vect_type), pointer :: xp, bp - integer :: info,fitmax,fitrace,first,fistop,fiter - character(len=20) :: fmethd - real(psb_spk_) :: feps,ferr + integer(psb_c_ipk) :: info,fitmax,fitrace,first,fistop,fiter + character(len=20) :: fmethd + real(psb_spk_) :: feps,ferr res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/krylov/psb_zkrylov_cbind_mod.f90 b/cbind/krylov/psb_zkrylov_cbind_mod.f90 index d2c9e60d7..92501f359 100644 --- a/cbind/krylov/psb_zkrylov_cbind_mod.f90 +++ b/cbind/krylov/psb_zkrylov_cbind_mod.f90 @@ -13,11 +13,11 @@ contains use psb_prec_cbind_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: ah type(psb_c_descriptor) :: cdh - type(psb_c_zprec) :: ph - type(psb_c_zvector) :: bh,xh + type(psb_c_zprec) :: ph + type(psb_c_zvector) :: bh,xh character(c_char) :: methd(*) type(solveroptions) :: options @@ -38,14 +38,14 @@ contains use psb_prec_cbind_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: ah type(psb_c_descriptor) :: cdh type(psb_c_zprec) :: ph type(psb_c_zvector) :: bh,xh - integer(psb_c_int), value :: itmax,itrace,irst,istop + integer(psb_c_ipk), value :: itmax,itrace,irst,istop real(c_double), value :: eps - integer(psb_c_int) :: iter + integer(psb_c_ipk) :: iter real(c_double) :: err character(c_char) :: methd(*) type(solveroptions) :: options @@ -54,9 +54,9 @@ contains type(psb_zprec_type), pointer :: precp type(psb_z_vect_type), pointer :: xp, bp - integer :: info,fitmax,fitrace,first,fistop,fiter - character(len=20) :: fmethd - real(psb_dpk_) :: feps,ferr + integer(psb_c_ipk) :: info,fitmax,fitrace,first,fistop,fiter + character(len=20) :: fmethd + real(psb_dpk_) :: feps,ferr res = -1 if (c_associated(cdh%item)) then diff --git a/cbind/prec/psb_cprec_cbind_mod.f90 b/cbind/prec/psb_cprec_cbind_mod.f90 index 67b26a9e3..c9304c660 100644 --- a/cbind/prec/psb_cprec_cbind_mod.f90 +++ b/cbind/prec/psb_cprec_cbind_mod.f90 @@ -18,12 +18,13 @@ contains use psb_prec_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int), value :: ictxt - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: ictxt + type(psb_c_cprec) :: ph character(c_char) :: ptype(*) type(psb_cprec_type), pointer :: precp - integer :: info + integer(psb_c_ipk) :: info character(len=80) :: fptype res = -1 @@ -52,7 +53,7 @@ contains use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cspmat) :: ah type(psb_c_cprec) :: ph type(psb_c_descriptor) :: cdh @@ -60,8 +61,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_cspmat_type), pointer :: ap type(psb_cprec_type), pointer :: precp - - integer :: info + integer(psb_c_ipk) :: info res = -1 !!$ write(*,*) 'Entry: ', psb_c_cd_get_local_rows(cdh) @@ -95,12 +95,10 @@ contains use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_cprec) :: ph - type(psb_cprec_type), pointer :: precp - - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(ph%item)) then diff --git a/cbind/prec/psb_dprec_cbind_mod.f90 b/cbind/prec/psb_dprec_cbind_mod.f90 index 50f0a0b78..2ea6c9fcd 100644 --- a/cbind/prec/psb_dprec_cbind_mod.f90 +++ b/cbind/prec/psb_dprec_cbind_mod.f90 @@ -18,12 +18,13 @@ contains use psb_prec_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int), value :: ictxt - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: ictxt + type(psb_c_dprec) :: ph character(c_char) :: ptype(*) type(psb_dprec_type), pointer :: precp - integer :: info + integer(psb_c_ipk) :: info character(len=80) :: fptype res = -1 @@ -52,7 +53,7 @@ contains use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dspmat) :: ah type(psb_c_dprec) :: ph type(psb_c_descriptor) :: cdh @@ -60,8 +61,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_dspmat_type), pointer :: ap type(psb_dprec_type), pointer :: precp - - integer :: info + integer(psb_c_ipk) :: info res = -1 !!$ write(*,*) 'Entry: ', psb_c_cd_get_local_rows(cdh) @@ -95,12 +95,10 @@ contains use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_dprec) :: ph - type(psb_dprec_type), pointer :: precp - - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(ph%item)) then diff --git a/cbind/prec/psb_sprec_cbind_mod.f90 b/cbind/prec/psb_sprec_cbind_mod.f90 index 9474949f8..87eedbfd2 100644 --- a/cbind/prec/psb_sprec_cbind_mod.f90 +++ b/cbind/prec/psb_sprec_cbind_mod.f90 @@ -18,12 +18,13 @@ contains use psb_prec_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int), value :: ictxt - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: ictxt + type(psb_c_sprec) :: ph character(c_char) :: ptype(*) type(psb_sprec_type), pointer :: precp - integer :: info + integer(psb_c_ipk) :: info character(len=80) :: fptype res = -1 @@ -52,7 +53,7 @@ contains use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sspmat) :: ah type(psb_c_sprec) :: ph type(psb_c_descriptor) :: cdh @@ -60,8 +61,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_sspmat_type), pointer :: ap type(psb_sprec_type), pointer :: precp - - integer :: info + integer(psb_c_ipk) :: info res = -1 !!$ write(*,*) 'Entry: ', psb_c_cd_get_local_rows(cdh) @@ -95,12 +95,10 @@ contains use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_sprec) :: ph - type(psb_sprec_type), pointer :: precp - - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(ph%item)) then diff --git a/cbind/prec/psb_zprec_cbind_mod.f90 b/cbind/prec/psb_zprec_cbind_mod.f90 index d428fcedb..b2bdcbe67 100644 --- a/cbind/prec/psb_zprec_cbind_mod.f90 +++ b/cbind/prec/psb_zprec_cbind_mod.f90 @@ -18,12 +18,13 @@ contains use psb_prec_mod use psb_base_string_cbind_mod implicit none - integer(psb_c_int), value :: ictxt - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res + integer(psb_c_ipk), value :: ictxt + type(psb_c_zprec) :: ph character(c_char) :: ptype(*) type(psb_zprec_type), pointer :: precp - integer :: info + integer(psb_c_ipk) :: info character(len=80) :: fptype res = -1 @@ -52,7 +53,7 @@ contains use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zspmat) :: ah type(psb_c_zprec) :: ph type(psb_c_descriptor) :: cdh @@ -60,8 +61,7 @@ contains type(psb_desc_type), pointer :: descp type(psb_zspmat_type), pointer :: ap type(psb_zprec_type), pointer :: precp - - integer :: info + integer(psb_c_ipk) :: info res = -1 !!$ write(*,*) 'Entry: ', psb_c_cd_get_local_rows(cdh) @@ -95,12 +95,10 @@ contains use psb_base_string_cbind_mod implicit none - integer(psb_c_int) :: res + integer(psb_c_ipk) :: res type(psb_c_zprec) :: ph - type(psb_zprec_type), pointer :: precp - - integer :: info + integer(psb_c_ipk) :: info res = -1 if (c_associated(ph%item)) then diff --git a/cbind/test/pargen/Makefile b/cbind/test/pargen/Makefile index 66120929b..8fa101d67 100644 --- a/cbind/test/pargen/Makefile +++ b/cbind/test/pargen/Makefile @@ -10,14 +10,10 @@ CINCLUDES=-I. -I$(HERE) -I$(INCLUDEDIR) PSBC_LIBS= -L$(LIBDIR) -lpsb_cbind PSB_LIBS=-lpsb_krylov -lpsb_prec -lpsb_base -L$(LIBDIR) -# -lpsb_krylov_cbind # # Compilers and such # -#CCOPT= -g -#FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). -CINCLUDES=-I$(LIBDIR) $(FIFLAG)$(INCLUDEDIR) $(FIFLAG)$(PSBLAS_INCDIR) EXEDIR=./runs @@ -25,9 +21,9 @@ all: ppdec ppdec: ppdec.o $(MPFC) ppdec.o -o ppdec $(PSBC_LIBS) $(PSB_LIBS) $(PSBLDLIBS) -lm -lgfortran + /bin/mv ppdec $(EXEDIR) # \ # -lifcore -lifcoremt -lguide -limf -lirc -lintlc -lcxaguard -L/opt/intel/fc/10.0.023/lib/ -lm - /bin/mv ppdec $(EXEDIR) .f90.o: $(MPFC) $(FCOPT) $(FINCLUDES) $(FDEFINES) -c $< diff --git a/cbind/test/pargen/ppdec.c b/cbind/test/pargen/ppdec.c index 32c5b6000..b4eda195e 100644 --- a/cbind/test/pargen/ppdec.c +++ b/cbind/test/pargen/ppdec.c @@ -98,15 +98,15 @@ double c(double x, double y, double z) } double b1(double x, double y, double z) { - return(1.0/sqrt(3.0)); + return(0.0/sqrt(3.0)); } double b2(double x, double y, double z) { - return(1.0/sqrt(3.0)); + return(0.0/sqrt(3.0)); } double b3(double x, double y, double z) { - return(1.0/sqrt(3.0)); + return(0.0/sqrt(3.0)); } double g(double x, double y, double z) @@ -120,14 +120,16 @@ double g(double x, double y, double z) } } -int matgen(int ictxt, int ng,int idim,int vg[],psb_c_dspmat *ah,psb_c_descriptor *cdh, - psb_c_dvector *xh, psb_c_dvector *bh, psb_c_dvector *rh) +psb_i_t matgen(psb_i_t ictxt, psb_i_t nl, psb_i_t idim, psb_l_t vl[], + psb_c_dspmat *ah,psb_c_descriptor *cdh, + psb_c_dvector *xh, psb_c_dvector *bh, psb_c_dvector *rh) { - int iam, np; - int ix, iy, iz, el,glob_row,i,info,ret; + psb_i_t iam, np; + psb_l_t ix, iy, iz, el,glob_row; + psb_i_t i, k, info,ret; double x, y, z, deltah, sqdeltah, deltah2; double val[10*NBMAX], zt[NBMAX]; - int irow[10*NBMAX], icol[10*NBMAX]; + psb_l_t irow[10*NBMAX], icol[10*NBMAX]; info = 0; psb_c_info(ictxt,&iam,&np); @@ -135,79 +137,77 @@ int matgen(int ictxt, int ng,int idim,int vg[],psb_c_dspmat *ah,psb_c_descriptor sqdeltah = deltah*deltah; deltah2 = 2.0* deltah; psb_c_set_index_base(0); - for (glob_row=0; glob_row < ng; glob_row++) { - - /* Check if I have to do something about this entry */ - if (vg[glob_row] == iam) { - el=0; - ix = glob_row/(idim*idim); - iy = (glob_row-ix*idim*idim)/idim; - iz = glob_row-ix*idim*idim-iy*idim; - x=(ix+1)*deltah; - y=(iy+1)*deltah; - z=(iz+1)*deltah; - zt[0] = 0.0; - /* internal point: build discretization */ - /* term depending on (x-1,y,z) */ - val[el] = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2; - if (ix==0) { - zt[0] += g(0.0,y,z)*(-val[el]); - } else { - icol[el]=(ix-1)*idim*idim+(iy)*idim+(iz); - el=el+1; - } - /* term depending on (x,y-1,z) */ - val[el] = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2; - if (iy==0) { - zt[0] += g(x,0.0,z)*(-val[el]); - } else { - icol[el]=(ix)*idim*idim+(iy-1)*idim+(iz); - el=el+1; - } - /* term depending on (x,y,z-1)*/ - val[el]=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2; - if (iz==0) { - zt[0] += g(x,y,0.0)*(-val[el]); - } else { - icol[el]=(ix)*idim*idim+(iy)*idim+(iz-1); - el=el+1; - } - /* term depending on (x,y,z)*/ - val[el]=2.0*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah + c(x,y,z); - icol[el]=(ix)*idim*idim+(iy)*idim+(iz); + for (i=0; idescriptor); + //fprintf(stderr,"pointer from cdfree: %p\n",cdh->descriptor); /* Clean up object handles */ free(ph); @@ -406,7 +412,7 @@ int main(int argc, char *argv[]) free(cdh); - fprintf(stderr,"program completed successfully\n"); + if (iam == 0) fprintf(stderr,"program completed successfully\n"); psb_c_barrier(ictxt); psb_c_exit(ictxt); diff --git a/cbind/test/pargen/runs/ppde.inp b/cbind/test/pargen/runs/ppde.inp index 225e6e7fc..e01625917 100644 --- a/cbind/test/pargen/runs/ppde.inp +++ b/cbind/test/pargen/runs/ppde.inp @@ -2,7 +2,7 @@ BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES BJAC Preconditioner NONE DIAG BJAC CSR A Storage format CSR COO -40 Domain size (acutal system is this**3) +100 Domain size (acutal system is this**3) 1 Stopping criterion 80 MAXIT 01 ITRACE diff --git a/config/pac.m4 b/config/pac.m4 index 689efd6a8..0f4f21690 100644 --- a/config/pac.m4 +++ b/config/pac.m4 @@ -395,6 +395,65 @@ fi ] ) +dnl @synopsis PAC_ARG_WITH_IPK +dnl +dnl Test for --with-ipk +dnl +dnl +dnl +dnl Example use: --with-ipk=4 +dnl +dnl +dnl @author Salvatore Filippone +dnl +AC_DEFUN([PAC_ARG_WITH_IPK], +[ +AC_MSG_CHECKING([what size in bytes we want for local indices and data]) +AC_ARG_WITH(ipk, + AC_HELP_STRING([--with-ipk=], + [Specify the size in bytes for local indices and data, default 4 bytes. ]), + [pac_cv_ipk_size=$withval;], + [pac_cv_ipk_size=4;] + ) +if test x"$pac_cv_ipk_size" == x"4" || test x"$pac_cv_ipk_size" == x"8" ; then + AC_MSG_RESULT([Size: $pac_cv_ipk_size.]) +else + AC_MSG_RESULT([Unsupported value for IPK: $pac_cv_ipk_size, defaulting to 4.]) + pac_cv_ipk_size=4; +fi +] +) + +dnl @synopsis PAC_ARG_WITH_LPK +dnl +dnl Test for --with-lpk +dnl +dnl +dnl +dnl Example use: --with-lpk=8 +dnl +dnl +dnl @author Salvatore Filippone +dnl +AC_DEFUN([PAC_ARG_WITH_LPK], +[ + AC_MSG_CHECKING([what size in bytes we want for global indices and data]) + AC_ARG_WITH(lpk, + AC_HELP_STRING([--with-lpk=], + [Specify the size in bytes for global indices and data, default 8 bytes. ]), + [pac_cv_lpk_size=$withval;], + [pac_cv_lpk_size=8;] + ) +if test x"$pac_cv_lpk_size" == x"4" || test x"$pac_cv_lpk_size" == x"8"; then + AC_MSG_RESULT([Size: $pac_cv_lpk_size.]) +else + AC_MSG_RESULT([Unsupported value for LPK: $pac_cv_lpk_size, defaulting to 8.]) + pac_cv_lpk_size=8; +fi +] +) + + dnl @synopsis PAC_FORTRAN_HAVE_PSBLAS( [ACTION-IF-FOUND [, ACTION-IF-NOT-FOUND]]) dnl dnl Will try to compile and link a program using the PSBLAS library diff --git a/configure b/configure index dd2094c84..ea3da3d44 100755 --- a/configure +++ b/configure @@ -1,20 +1,22 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.63 for PSBLAS 3.5. +# Generated by GNU Autoconf 2.69 for PSBLAS 3.5. # # Report bugs to . # -# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -# 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. -## --------------------- ## -## M4sh Initialization. ## -## --------------------- ## +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which @@ -22,23 +24,15 @@ if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else - case `(set -o) 2>/dev/null` in - *posix*) set -o posix ;; + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; esac - fi - - -# PATH needs CR -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - as_nl=' ' export as_nl @@ -46,7 +40,13 @@ export as_nl as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -if (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else @@ -57,7 +57,7 @@ else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; - case $arg in + case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; @@ -80,13 +80,6 @@ if test "${PATH_SEPARATOR+set}" != set; then } fi -# Support unset when possible. -if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then - as_unset=unset -else - as_unset=false -fi - # IFS # We need space, tab and new line, in precisely that order. Quoting is @@ -96,15 +89,16 @@ fi IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. -case $0 in +as_myself= +case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break -done + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done IFS=$as_save_IFS ;; @@ -116,12 +110,16 @@ if test "x$as_myself" = x; then fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - { (exit 1); exit 1; } + exit 1 fi -# Work around bugs in pre-3.0 UWIN ksh. -for as_var in ENV MAIL MAILPATH -do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' @@ -133,7 +131,294 @@ export LC_ALL LANGUAGE=C export LANGUAGE -# Required to use basename. +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 +test \$(( 1 + 1 )) = 2 || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org and +$0: https://github.com/sfilippone/psblas3/issues about your +$0: system, including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr @@ -147,8 +432,12 @@ else as_basename=false fi +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi -# Name of the executable. as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ @@ -168,295 +457,19 @@ $as_echo X/"$0" | } s/.*/./; q'` -# CDPATH. -$as_unset CDPATH +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits -if test "x$CONFIG_SHELL" = x; then - if (eval ":") 2>/dev/null; then - as_have_required=yes -else - as_have_required=no -fi - - if test $as_have_required = yes && (eval ": -(as_func_return () { - (exit \$1) -} -as_func_success () { - as_func_return 0 -} -as_func_failure () { - as_func_return 1 -} -as_func_ret_success () { - return 0 -} -as_func_ret_failure () { - return 1 -} - -exitcode=0 -if as_func_success; then - : -else - exitcode=1 - echo as_func_success failed. -fi - -if as_func_failure; then - exitcode=1 - echo as_func_failure succeeded. -fi - -if as_func_ret_success; then - : -else - exitcode=1 - echo as_func_ret_success failed. -fi - -if as_func_ret_failure; then - exitcode=1 - echo as_func_ret_failure succeeded. -fi - -if ( set x; as_func_ret_success y && test x = \"\$1\" ); then - : -else - exitcode=1 - echo positional parameters were not saved. -fi - -test \$exitcode = 0) || { (exit 1); exit 1; } - -( - as_lineno_1=\$LINENO - as_lineno_2=\$LINENO - test \"x\$as_lineno_1\" != \"x\$as_lineno_2\" && - test \"x\`expr \$as_lineno_1 + 1\`\" = \"x\$as_lineno_2\") || { (exit 1); exit 1; } -") 2> /dev/null; then - : -else - as_candidate_shells= - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - case $as_dir in - /*) - for as_base in sh bash ksh sh5; do - as_candidate_shells="$as_candidate_shells $as_dir/$as_base" - done;; - esac -done -IFS=$as_save_IFS - - - for as_shell in $as_candidate_shells $SHELL; do - # Try only shells that exist, to save several forks. - if { test -f "$as_shell" || test -f "$as_shell.exe"; } && - { ("$as_shell") 2> /dev/null <<\_ASEOF -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in - *posix*) set -o posix ;; -esac - -fi - - -: -_ASEOF -}; then - CONFIG_SHELL=$as_shell - as_have_required=yes - if { "$as_shell" 2> /dev/null <<\_ASEOF -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then - emulate sh - NULLCMD=: - # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which - # is contrary to our usage. Disable this feature. - alias -g '${1+"$@"}'='"$@"' - setopt NO_GLOB_SUBST -else - case `(set -o) 2>/dev/null` in - *posix*) set -o posix ;; -esac - -fi - - -: -(as_func_return () { - (exit $1) -} -as_func_success () { - as_func_return 0 -} -as_func_failure () { - as_func_return 1 -} -as_func_ret_success () { - return 0 -} -as_func_ret_failure () { - return 1 -} - -exitcode=0 -if as_func_success; then - : -else - exitcode=1 - echo as_func_success failed. -fi - -if as_func_failure; then - exitcode=1 - echo as_func_failure succeeded. -fi - -if as_func_ret_success; then - : -else - exitcode=1 - echo as_func_ret_success failed. -fi - -if as_func_ret_failure; then - exitcode=1 - echo as_func_ret_failure succeeded. -fi - -if ( set x; as_func_ret_success y && test x = "$1" ); then - : -else - exitcode=1 - echo positional parameters were not saved. -fi - -test $exitcode = 0) || { (exit 1); exit 1; } - -( - as_lineno_1=$LINENO - as_lineno_2=$LINENO - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2") || { (exit 1); exit 1; } - -_ASEOF -}; then - break -fi - -fi - - done - - if test "x$CONFIG_SHELL" != x; then - for as_var in BASH_ENV ENV - do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var - done - export CONFIG_SHELL - exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} -fi - - - if test $as_have_required = no; then - echo This script requires a shell more modern than all the - echo shells that I found on your system. Please install a - echo modern shell, or manually run the script under such a - echo shell if you do have one. - { (exit 1); exit 1; } -fi - - -fi - -fi - - - -(eval "as_func_return () { - (exit \$1) -} -as_func_success () { - as_func_return 0 -} -as_func_failure () { - as_func_return 1 -} -as_func_ret_success () { - return 0 -} -as_func_ret_failure () { - return 1 -} - -exitcode=0 -if as_func_success; then - : -else - exitcode=1 - echo as_func_success failed. -fi - -if as_func_failure; then - exitcode=1 - echo as_func_failure succeeded. -fi - -if as_func_ret_success; then - : -else - exitcode=1 - echo as_func_ret_success failed. -fi - -if as_func_ret_failure; then - exitcode=1 - echo as_func_ret_failure succeeded. -fi - -if ( set x; as_func_ret_success y && test x = \"\$1\" ); then - : -else - exitcode=1 - echo positional parameters were not saved. -fi - -test \$exitcode = 0") || { - echo No shell found that supports shell functions. - echo Please tell bug-autoconf@gnu.org about your system, - echo including any error possibly output before this message. - echo This can help us improve future autoconf versions. - echo Configuration will now proceed without shell functions. -} - - - - as_lineno_1=$LINENO - as_lineno_2=$LINENO - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || { - - # Create $as_me.lineno as a copy of $as_myself, but with $LINENO - # uniformly replaced by the line number. The first 'sed' inserts a - # line-number line after each line using $LINENO; the second 'sed' - # does the real work. The second script uses 'N' to pair each - # line-number line with the line containing $LINENO, and appends - # trailing '-' during substitution so that $LINENO is not a special - # case at line end. - # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the - # scripts with optimization help from Paolo Bonzini. Blame Lee - # E. McMahon (1931-1989) for sed's syntax. :-) + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= @@ -473,9 +486,12 @@ test \$exitcode = 0") || { s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 - { (exit 1); exit 1; }; } + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). @@ -484,29 +500,18 @@ test \$exitcode = 0") || { exit } - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi - ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in +case `echo -n x` in #((((( -n*) - case `echo 'x\c'` in + case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. - *) ECHO_C='\c';; + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then @@ -521,49 +526,29 @@ if (echo >conf$$.file) 2>/dev/null; then # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' + as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then - as_mkdir_p=: + as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x +as_test_x='test -x' +as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" @@ -572,11 +557,11 @@ as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" - -exec 7<&0 &1 +test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. -# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` @@ -591,7 +576,6 @@ cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= -SHELL=${CONFIG_SHELL-/bin/sh} # Identity of this package. PACKAGE_NAME='PSBLAS' @@ -599,6 +583,7 @@ PACKAGE_TARNAME='psblas' PACKAGE_VERSION='3.5' PACKAGE_STRING='PSBLAS 3.5' PACKAGE_BUGREPORT='https://github.com/sfilippone/psblas3/issues' +PACKAGE_URL='' ac_unique_file="base/modules/psb_base_mod.f90" # Factoring default headers for most tests. @@ -680,9 +665,14 @@ LAPACK_LIBS EGREP GREP CPP +AM_BACKSLASH +AM_DEFAULT_VERBOSITY +AM_DEFAULT_V +AM_V am__fastdepCC_FALSE am__fastdepCC_TRUE CCDEPMODE +am__nodep AMDEPBACKSLASH AMDEP_FALSE AMDEP_TRUE @@ -756,6 +746,7 @@ bindir program_transform_name prefix exec_prefix +PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION @@ -776,7 +767,9 @@ with_library_path with_include_path with_module_path enable_dependency_tracking -enable_long_integers +enable_silent_rules +with_ipk +with_lpk with_blas with_blasdir with_lapack @@ -865,8 +858,9 @@ do fi case $ac_option in - *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; - *) ac_optarg=yes ;; + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. @@ -911,8 +905,7 @@ do ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - { $as_echo "$as_me: error: invalid feature name: $ac_useropt" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -938,8 +931,7 @@ do ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - { $as_echo "$as_me: error: invalid feature name: $ac_useropt" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1143,8 +1135,7 @@ do ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - { $as_echo "$as_me: error: invalid package name: $ac_useropt" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1160,8 +1151,7 @@ do ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - { $as_echo "$as_me: error: invalid package name: $ac_useropt" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1191,17 +1181,17 @@ do | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; - -*) { $as_echo "$as_me: error: unrecognized option: $ac_option -Try \`$0 --help' for more information." >&2 - { (exit 1); exit 1; }; } + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. - expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && - { $as_echo "$as_me: error: invalid variable name: $ac_envvar" >&2 - { (exit 1); exit 1; }; } + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; @@ -1210,7 +1200,7 @@ Try \`$0 --help' for more information." >&2 $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 - : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac @@ -1218,15 +1208,13 @@ done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` - { $as_echo "$as_me: error: missing argument to $ac_option" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; - fatal) { $as_echo "$as_me: error: unrecognized options: $ac_unrecognized_opts" >&2 - { (exit 1); exit 1; }; } ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi @@ -1249,8 +1237,7 @@ do [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac - { $as_echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' @@ -1264,8 +1251,6 @@ target=$target_alias if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe - $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. - If a cross compiler is detected then cross compile mode will be used." >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi @@ -1280,11 +1265,9 @@ test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || - { $as_echo "$as_me: error: working directory cannot be determined" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || - { $as_echo "$as_me: error: pwd does not report name of working directory" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. @@ -1323,13 +1306,11 @@ else fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." - { $as_echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 - { (exit 1); exit 1; }; } + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( - cd "$srcdir" && test -r "./$ac_unique_file" || { $as_echo "$as_me: error: $ac_msg" >&2 - { (exit 1); exit 1; }; } + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then @@ -1369,7 +1350,7 @@ Configuration: --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking...' messages + -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files @@ -1431,30 +1412,37 @@ Optional Features: --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --enable-serial Specify whether to enable a fake mpi library to run in serial mode. - --disable-dependency-tracking speeds up one-time build - --enable-dependency-tracking do not reject slow dependency extractors - --enable-long-integers Specify usage of 64 bits integers. + --enable-dependency-tracking + do not reject slow dependency extractors + --disable-dependency-tracking + speeds up one-time build + --enable-silent-rules less verbose build output (undo: "make V=1") + --disable-silent-rules verbose build output (undo: "make V=0") Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --with-ccopt additional CCOPT flags to be added: will prepend - to CCOPT - --with-fcopt additional FCOPT flags to be added: will prepend - to FCOPT + --with-ccopt additional [CCOPT] flags to be added: will prepend + to [CCOPT] + --with-fcopt additional [FCOPT] flags to be added: will prepend + to [FCOPT] --with-libs List additional link flags here. For example, --with-libs=-lspecial_system_lib or --with-libs=-L/path/to/libs - --with-clibs additional CLIBS flags to be added: will prepend - to CLIBS - --with-flibs additional FLIBS flags to be added: will prepend - to FLIBS - --with-library-path additional LIBRARYPATH flags to be added: will - prepend to LIBRARYPATH - --with-include-path additional INCLUDEPATH flags to be added: will - prepend to INCLUDEPATH - --with-module-path additional MODULE_PATH flags to be added: will - prepend to MODULE_PATH + --with-clibs additional [CLIBS] flags to be added: will prepend + to [CLIBS] + --with-flibs additional [FLIBS] flags to be added: will prepend + to [FLIBS] + --with-library-path additional [LIBRARYPATH] flags to be added: will + prepend to [LIBRARYPATH] + --with-include-path additional [INCLUDEPATH] flags to be added: will + prepend to [INCLUDEPATH] + --with-module-path additional [MODULE_PATH] flags to be added: will + prepend to [MODULE_PATH] + --with-ipk= Specify the size in bytes for local indices and + data, default 4 bytes. + --with-lpk= Specify the size in bytes for global indices and + data, default 8 bytes. --with-blas= use BLAS library --with-blasdir= search for BLAS library in --with-lapack= use LAPACK library @@ -1484,7 +1472,7 @@ Some influential environment variables: LIBS libraries to pass to the linker, e.g. -l CC C compiler command CFLAGS C compiler flags - CPPFLAGS C/C++/Objective C preprocessor flags, e.g. -I if + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory MPICC MPI C compiler command MPIFC MPI Fortran compiler command @@ -1557,21 +1545,643 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF PSBLAS configure 3.5 -generated by GNU Autoconf 2.63 +generated by GNU Autoconf 2.69 -Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, -2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_fc_try_compile LINENO +# --------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_fc_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_fc_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_fc_try_compile + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_try_link LINENO +# ----------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link + +# ac_fn_c_check_func LINENO FUNC VAR +# ---------------------------------- +# Tests whether FUNC exists, setting the cache variable VAR accordingly +ac_fn_c_check_func () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +/* Define $2 to an innocuous variant, in case declares $2. + For example, HP-UX 11i declares gettimeofday. */ +#define $2 innocuous_$2 + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $2 (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $2 + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $2 (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$2 || defined __stub___$2 +choke me +#endif + +int +main () +{ +return $2 (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_func + +# ac_fn_fc_try_link LINENO +# ------------------------ +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_fc_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_fc_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_fc_try_link + +# ac_fn_c_try_run LINENO +# ---------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes +# that executables *can* be run. +ac_fn_c_try_run () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then : + ac_retval=0 +else + $as_echo "$as_me: program exited with status $ac_status" >&5 + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=$ac_status +fi + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_run + +# ac_fn_c_compute_int LINENO EXPR VAR INCLUDES +# -------------------------------------------- +# Tries to find the compile-time value of EXPR in a program that includes +# INCLUDES, setting VAR accordingly. Returns whether the value could be +# computed +ac_fn_c_compute_int () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if test "$cross_compiling" = yes; then + # Depending upon the size, compute the lo and hi bounds. +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) >= 0)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_lo=0 ac_mid=0 + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) <= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=$ac_mid; break +else + as_fn_arith $ac_mid + 1 && ac_lo=$as_val + if test $ac_lo -le $ac_mid; then + ac_lo= ac_hi= + break + fi + as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + done +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) < 0)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=-1 ac_mid=-1 + while :; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) >= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_lo=$ac_mid; break +else + as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val + if test $ac_mid -le $ac_hi; then + ac_lo= ac_hi= + break + fi + as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + done +else + ac_lo= ac_hi= +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +# Binary search between lo and hi bounds. +while test "x$ac_lo" != "x$ac_hi"; do + as_fn_arith '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo && ac_mid=$as_val + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +static int test_array [1 - 2 * !(($2) <= $ac_mid)]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_hi=$ac_mid +else + as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +done +case $ac_lo in #(( +?*) eval "$3=\$ac_lo"; ac_retval=0 ;; +'') ac_retval=1 ;; +esac + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +static long int longval () { return $2; } +static unsigned long int ulongval () { return $2; } +#include +#include +int +main () +{ + + FILE *f = fopen ("conftest.val", "w"); + if (! f) + return 1; + if (($2) < 0) + { + long int i = longval (); + if (i != ($2)) + return 1; + fprintf (f, "%ld", i); + } + else + { + unsigned long int i = ulongval (); + if (i != ($2)) + return 1; + fprintf (f, "%lu", i); + } + /* Do not output a trailing newline, as this causes \r\n confusion + on some platforms. */ + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + echo >>conftest.val; read $3 &5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } > conftest.i && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_cpp + +# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists and can be compiled using the include files in +# INCLUDES, setting the cache variable VAR accordingly. +ac_fn_c_check_header_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_compile + +# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists, giving a warning if it cannot be compiled using +# the include files in INCLUDES and setting the cache variable VAR +# accordingly. +ac_fn_c_check_header_mongrel () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +else + # Is the header compilable? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 +$as_echo_n "checking $2 usability... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_header_compiler=yes +else + ac_header_compiler=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 +$as_echo "$ac_header_compiler" >&6; } + +# Is the header present? +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 +$as_echo_n "checking $2 presence... " >&6; } +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <$2> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + ac_header_preproc=yes +else + ac_header_preproc=no +fi +rm -f conftest.err conftest.i conftest.$ac_ext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 +$as_echo "$ac_header_preproc" >&6; } + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( + yes:no: ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 +$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} + ;; + no:yes:* ) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 +$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 +$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 +$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 +$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 +$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} +( $as_echo "## ----------------------------------------------------------- ## +## Report this to https://github.com/sfilippone/psblas3/issues ## +## ----------------------------------------------------------- ##" + ) | sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=\$ac_header_compiler" +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_mongrel cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by PSBLAS $as_me 3.5, which was -generated by GNU Autoconf 2.63. Invocation command line was +generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -1607,8 +2217,8 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - $as_echo "PATH: $as_dir" -done + $as_echo "PATH: $as_dir" + done IFS=$as_save_IFS } >&5 @@ -1645,9 +2255,9 @@ do ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in - 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) - ac_configure_args1="$ac_configure_args1 '$ac_arg'" + as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else @@ -1663,13 +2273,13 @@ do -* ) ac_must_keep_next=true ;; esac fi - ac_configure_args="$ac_configure_args '$ac_arg'" + as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done -$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } -$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there @@ -1681,11 +2291,9 @@ trap 'exit_status=$? { echo - cat <<\_ASBOX -## ---------------- ## + $as_echo "## ---------------- ## ## Cache variables. ## -## ---------------- ## -_ASBOX +## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( @@ -1694,13 +2302,13 @@ _ASBOX case $ac_val in #( *${as_nl}*) case $ac_var in #( - *_cv_*) { $as_echo "$as_me:$LINENO: WARNING: cache variable $ac_var contains a newline" >&5 + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) $as_unset $ac_var ;; + *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done @@ -1719,11 +2327,9 @@ $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; ) echo - cat <<\_ASBOX -## ----------------- ## + $as_echo "## ----------------- ## ## Output variables. ## -## ----------------- ## -_ASBOX +## ----------------- ##" echo for ac_var in $ac_subst_vars do @@ -1736,11 +2342,9 @@ _ASBOX echo if test -n "$ac_subst_files"; then - cat <<\_ASBOX -## ------------------- ## + $as_echo "## ------------------- ## ## File substitutions. ## -## ------------------- ## -_ASBOX +## ------------------- ##" echo for ac_var in $ac_subst_files do @@ -1754,11 +2358,9 @@ _ASBOX fi if test -s confdefs.h; then - cat <<\_ASBOX -## ----------- ## + $as_echo "## ----------- ## ## confdefs.h. ## -## ----------- ## -_ASBOX +## ----------- ##" echo cat confdefs.h echo @@ -1772,46 +2374,53 @@ _ASBOX exit $exit_status ' 0 for ac_signal in 1 2 13 15; do - trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h +$as_echo "/* confdefs.h */" > confdefs.h + # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF - cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF - cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF - cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF - cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then - ac_site_file1=$CONFIG_SITE + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site @@ -1822,19 +2431,23 @@ fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue - if test -r "$ac_site_file"; then - { $as_echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 - . "$ac_site_file" + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then - # Some versions of bash will fail to source /dev/null (special - # files actually), so we avoid doing that. - if test -f "$cache_file"; then - { $as_echo "$as_me:$LINENO: loading cache $cache_file" >&5 + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; @@ -1842,7 +2455,7 @@ $as_echo "$as_me: loading cache $cache_file" >&6;} esac fi else - { $as_echo "$as_me:$LINENO: creating cache $cache_file" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi @@ -1857,11 +2470,11 @@ for ac_var in $ac_precious_vars; do eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) - { $as_echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) - { $as_echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; @@ -1871,17 +2484,17 @@ $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then - { $as_echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else - { $as_echo "$as_me:$LINENO: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi - { $as_echo "$as_me:$LINENO: former value: \`$ac_old_val'" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} - { $as_echo "$as_me:$LINENO: current value: \`$ac_new_val'" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac @@ -1893,43 +2506,20 @@ $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. - *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then - { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} - { { $as_echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 -$as_echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi - - - - - - - - - - - - - - - - - - - - - - - - +## -------------------- ## +## Main body of script. ## +## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -1948,7 +2538,7 @@ psblas_cv_version="3.5" # Our custom M4 macros are in the 'config' directory -{ $as_echo "$as_me:$LINENO: +{ $as_echo "$as_me:${as_lineno-$LINENO}: -------------------------------------------------------------------------------- Welcome to the $PACKAGE_NAME $psblas_cv_version configure Script. @@ -2000,9 +2590,7 @@ for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do fi done if test -z "$ac_aux_dir"; then - { { $as_echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&5 -$as_echo "$as_me: error: cannot find install-sh or install.sh in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 fi # These three variables are undocumented and unsupported, @@ -2028,10 +2616,10 @@ ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. -{ $as_echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then -if test "${ac_cv_path_install+set}" = set; then +if ${ac_cv_path_install+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2039,11 +2627,11 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - # Account for people who put trailing slashes in PATH elements. -case $as_dir/ in - ./ | .// | /cC/* | \ + # Account for people who put trailing slashes in PATH elements. +case $as_dir/ in #(( + ./ | .// | /[cC]/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ - ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ + ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. @@ -2051,7 +2639,7 @@ case $as_dir/ in # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then + if as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. @@ -2080,7 +2668,7 @@ case $as_dir/ in ;; esac -done + done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir @@ -2096,7 +2684,7 @@ fi INSTALL=$ac_install_sh fi fi -{ $as_echo "$as_me:$LINENO: result: $INSTALL" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. @@ -2108,7 +2696,7 @@ test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' -{ $as_echo "$as_me:$LINENO: checking where to install" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking where to install" >&5 $as_echo_n "checking where to install... " >&6; } case $prefix in \/* ) eval "INSTALL_DIR=$prefix";; @@ -2131,7 +2719,7 @@ case $samplesdir in * ) eval "INSTALL_SAMPLESDIR=$INSTALL_DIR/samples";; esac INSTALL_MODULESDIR=$INSTALL_DIR/modules -{ $as_echo "$as_me:$LINENO: result: $INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_MODULESDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR $INSTALL_SAMPLESDIR" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_MODULESDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR $INSTALL_SAMPLESDIR" >&5 $as_echo "$INSTALL_DIR $INSTALL_INCLUDEDIR $INSTALL_MODULESDIR $INSTALL_LIBDIR $INSTALL_DOCSDIR $INSTALL_SAMPLESDIR" >&6; } save_FCFLAGS="$FCFLAGS"; @@ -2144,9 +2732,9 @@ if test -n "$ac_tool_prefix"; then do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_FC+set}" = set; then +if ${ac_cv_prog_FC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$FC"; then @@ -2157,24 +2745,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_FC="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi FC=$ac_cv_prog_FC if test -n "$FC"; then - { $as_echo "$as_me:$LINENO: result: $FC" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $FC" >&5 $as_echo "$FC" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -2188,9 +2776,9 @@ if test -z "$FC"; then do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_ac_ct_FC+set}" = set; then +if ${ac_cv_prog_ac_ct_FC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_FC"; then @@ -2201,24 +2789,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_FC="$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi ac_ct_FC=$ac_cv_prog_ac_ct_FC if test -n "$ac_ct_FC"; then - { $as_echo "$as_me:$LINENO: result: $ac_ct_FC" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_FC" >&5 $as_echo "$ac_ct_FC" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -2231,7 +2819,7 @@ done else case $cross_compiling:$ac_tool_warned in yes:) -{ $as_echo "$as_me:$LINENO: WARNING: using cross tools not prefixed with host triplet" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac @@ -2241,45 +2829,32 @@ fi # Provide some information about the compiler. -$as_echo "$as_me:$LINENO: checking for Fortran compiler version" >&5 +$as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler version" >&5 set X $ac_compile ac_compiler=$2 -{ (ac_try="$ac_compiler --version >&5" +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compiler --version >&5") 2>&5 +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -{ (ac_try="$ac_compiler -v >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compiler -v >&5") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -{ (ac_try="$ac_compiler -V >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compiler -V >&5") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done rm -f a.out -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main end @@ -2289,8 +2864,8 @@ ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. -{ $as_echo "$as_me:$LINENO: checking for Fortran compiler default output file name" >&5 -$as_echo_n "checking for Fortran compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the Fortran compiler works" >&5 +$as_echo_n "checking whether the Fortran compiler works... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: @@ -2306,17 +2881,17 @@ do done rm -f $ac_rmfiles -if { (ac_try="$ac_link_default" +if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, @@ -2333,7 +2908,7 @@ do # certainly right. break;; *.* ) - if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi @@ -2352,84 +2927,41 @@ test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi - -{ $as_echo "$as_me:$LINENO: result: $ac_file" >&5 -$as_echo "$ac_file" >&6; } -if test -z "$ac_file"; then - $as_echo "$as_me: failed program was:" >&5 +if test -z "$ac_file"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +$as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: Fortran compiler cannot create executables -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: Fortran compiler cannot create executables -See \`config.log' for more details." >&2;} - { (exit 77); exit 77; }; }; } -fi - -ac_exeext=$ac_cv_exeext - -# Check that the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -{ $as_echo "$as_me:$LINENO: checking whether the Fortran compiler works" >&5 -$as_echo_n "checking whether the Fortran compiler works... " >&6; } -# FIXME: These cross compiler hacks should be removed for Autoconf 3.0 -# If not cross compiling, check that we can run a simple program. -if test "$cross_compiling" != yes; then - if { ac_try='./$ac_file' - { (case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - cross_compiling=no - else - if test "$cross_compiling" = maybe; then - cross_compiling=yes - else - { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: cannot run Fortran compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: cannot run Fortran compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; }; } - fi - fi -fi -{ $as_echo "$as_me:$LINENO: result: yes" >&5 +as_fn_error 77 "Fortran compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran compiler default output file name" >&5 +$as_echo_n "checking for Fortran compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +$as_echo "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save -# Check that the compiler produces executables we can run. If not, either -# the compiler is broken, or we cross compile. -{ $as_echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 -$as_echo_n "checking whether we are cross compiling... " >&6; } -{ $as_echo "$as_me:$LINENO: result: $cross_compiling" >&5 -$as_echo "$cross_compiling" >&6; } - -{ $as_echo "$as_me:$LINENO: checking for suffix of executables" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } -if { (ac_try="$ac_link" +if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with @@ -2444,44 +2976,93 @@ for ac_file in conftest.exe conftest conftest.*; do esac done else - { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; }; } +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } fi - -rm -f conftest$ac_cv_exeext -{ $as_echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 +rm -f conftest conftest$ac_cv_exeext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT -{ $as_echo "$as_me:$LINENO: checking for suffix of object files" >&5 +cat > conftest.$ac_ext <<_ACEOF + program main + open(unit=9,file='conftest.out') + close(unit=9) + + end +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +$as_echo_n "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run Fortran compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +$as_echo "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } -if test "${ac_cv_objext+set}" = set; then +if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF rm -f conftest.o conftest.obj -if { (ac_try="$ac_compile" +if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; then + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in @@ -2494,18 +3075,14 @@ else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: cannot compute suffix of object files: cannot compile -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; }; } +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } fi - rm -f conftest.$ac_cv_objext conftest.$ac_ext fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT @@ -2513,12 +3090,12 @@ ac_objext=$OBJEXT # input file. (Note that this only needs to work for GNU compilers.) ac_save_ext=$ac_ext ac_ext=F -{ $as_echo "$as_me:$LINENO: checking whether we are using the GNU Fortran compiler" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran compiler" >&5 $as_echo_n "checking whether we are using the GNU Fortran compiler... " >&6; } -if test "${ac_cv_fc_compiler_gnu+set}" = set; then +if ${ac_cv_fc_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main #ifndef __GNUC__ choke me @@ -2526,86 +3103,44 @@ else end _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_fc_try_compile "$LINENO"; then : ac_compiler_gnu=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_compiler_gnu=no + ac_compiler_gnu=no fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_fc_compiler_gnu=$ac_compiler_gnu fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_fc_compiler_gnu" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_compiler_gnu" >&5 $as_echo "$ac_cv_fc_compiler_gnu" >&6; } ac_ext=$ac_save_ext -ac_test_FFLAGS=${FCFLAGS+set} -ac_save_FFLAGS=$FCFLAGS +ac_test_FCFLAGS=${FCFLAGS+set} +ac_save_FCFLAGS=$FCFLAGS FCFLAGS= -{ $as_echo "$as_me:$LINENO: checking whether $FC accepts -g" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $FC accepts -g" >&5 $as_echo_n "checking whether $FC accepts -g... " >&6; } -if test "${ac_cv_prog_fc_g+set}" = set; then +if ${ac_cv_prog_fc_g+:} false; then : $as_echo_n "(cached) " >&6 else FCFLAGS=-g -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_fc_try_compile "$LINENO"; then : ac_cv_prog_fc_g=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_prog_fc_g=no + ac_cv_prog_fc_g=no fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_prog_fc_g" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_fc_g" >&5 $as_echo "$ac_cv_prog_fc_g" >&6; } -if test "$ac_test_FFLAGS" = set; then - FCFLAGS=$ac_save_FFLAGS +if test "$ac_test_FCFLAGS" = set; then + FCFLAGS=$ac_save_FCFLAGS elif test $ac_cv_prog_fc_g = yes; then if test "x$ac_cv_fc_compiler_gnu" = xyes; then FCFLAGS="-g -O2" @@ -2620,6 +3155,11 @@ else fi fi +if test $ac_compiler_gnu = yes; then + GFC=yes +else + GFC= +fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' @@ -2638,9 +3178,9 @@ if test -n "$ac_tool_prefix"; then do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_CC+set}" = set; then +if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then @@ -2651,24 +3191,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then - { $as_echo "$as_me:$LINENO: result: $CC" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -2682,9 +3222,9 @@ if test -z "$CC"; then do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_ac_ct_CC+set}" = set; then +if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then @@ -2695,24 +3235,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then - { $as_echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -2725,7 +3265,7 @@ done else case $cross_compiling:$ac_tool_warned in yes:) -{ $as_echo "$as_me:$LINENO: WARNING: using cross tools not prefixed with host triplet" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac @@ -2734,62 +3274,42 @@ esac fi -test -z "$CC" && { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 +test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: no acceptable C compiler found in \$PATH -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; }; } +as_fn_error $? "no acceptable C compiler found in \$PATH +See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. -$as_echo "$as_me:$LINENO: checking for C compiler version" >&5 +$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 -{ (ac_try="$ac_compiler --version >&5" +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compiler --version >&5") 2>&5 +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -{ (ac_try="$ac_compiler -v >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compiler -v >&5") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } -{ (ac_try="$ac_compiler -V >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compiler -V >&5") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done -{ $as_echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } -if test "${ac_cv_c_compiler_gnu+set}" = set; then +if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -2803,37 +3323,16 @@ main () return 0; } _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_compiler_gnu=no + ac_compiler_gnu=no fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes @@ -2842,20 +3341,16 @@ else fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS -{ $as_echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } -if test "${ac_cv_prog_cc_g+set}" = set; then +if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -2866,35 +3361,11 @@ main () return 0; } _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - CFLAGS="" - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -2905,36 +3376,12 @@ main () return 0; } _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - : -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 +if ac_fn_c_try_compile "$LINENO"; then : - ac_c_werror_flag=$ac_save_c_werror_flag +else + ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -2945,42 +3392,17 @@ main () return 0; } _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS @@ -2997,23 +3419,18 @@ else CFLAGS= fi fi -{ $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } -if test "${ac_cv_prog_cc_c89+set}" = set; then +if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include -#include -#include +struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); @@ -3065,32 +3482,9 @@ for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" - rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then + if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done @@ -3101,17 +3495,19 @@ fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) - { $as_echo "$as_me:$LINENO: result: none needed" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) - { $as_echo "$as_me:$LINENO: result: unsupported" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" - { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac +if test "x$ac_cv_prog_cc_c89" != xno; then : +fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -3119,35 +3515,91 @@ ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu +# Expand $ac_aux_dir to an absolute path. +am_aux_dir=`cd "$ac_aux_dir" && pwd` + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC understands -c and -o together" >&5 +$as_echo_n "checking whether $CC understands -c and -o together... " >&6; } +if ${am_cv_prog_cc_c_o+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF + # Make sure it works both with $CC and with simple cc. + # Following AC_PROG_CC_C_O, we do the test twice because some + # compilers refuse to overwrite an existing .o file with -o, + # though they will create one. + am_cv_prog_cc_c_o=yes + for am_i in 1 2; do + if { echo "$as_me:$LINENO: $CC -c conftest.$ac_ext -o conftest2.$ac_objext" >&5 + ($CC -c conftest.$ac_ext -o conftest2.$ac_objext) >&5 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } \ + && test -f conftest2.$ac_objext; then + : OK + else + am_cv_prog_cc_c_o=no + break + fi + done + rm -f core conftest* + unset am_i +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_prog_cc_c_o" >&5 +$as_echo "$am_cv_prog_cc_c_o" >&6; } +if test "$am_cv_prog_cc_c_o" != yes; then + # Losing compiler, so override with the script. + # FIXME: It is wrong to rewrite CC. + # But if we don't then we get into trouble of one sort or another. + # A longer-term fix would be to have automake use am__CC in this case, + # and then we could set am__CC="\$(top_srcdir)/compile \$(CC)" + CC="$am_aux_dir/compile $CC" +fi +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + CFLAGS="$save_CFLAGS"; # Sanity checks, although redundant (useful when debugging this configure.ac)! if test "X$FC" == "X" ; then - { { $as_echo "$as_me:$LINENO: error: Problem : No Fortran compiler specified nor found!" >&5 -$as_echo "$as_me: error: Problem : No Fortran compiler specified nor found!" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Problem : No Fortran compiler specified nor found!" "$LINENO" 5 fi if test "X$CC" == "X" ; then - { { $as_echo "$as_me:$LINENO: error: Problem : No C compiler specified nor found!" >&5 -$as_echo "$as_me: error: Problem : No C compiler specified nor found!" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Problem : No C compiler specified nor found!" "$LINENO" 5 fi - case $ac_cv_prog_cc_stdc in - no) ac_cv_prog_cc_c99=no; ac_cv_prog_cc_c89=no ;; - *) { $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO C99" >&5 + case $ac_cv_prog_cc_stdc in #( + no) : + ac_cv_prog_cc_c99=no; ac_cv_prog_cc_c89=no ;; #( + *) : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C99" >&5 $as_echo_n "checking for $CC option to accept ISO C99... " >&6; } -if test "${ac_cv_prog_cc_c99+set}" = set; then +if ${ac_cv_prog_cc_c99+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c99=no ac_save_CC=$CC -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include @@ -3286,35 +3738,12 @@ main () return 0; } _ACEOF -for ac_arg in '' -std=gnu99 -std=c99 -c99 -AC99 -xc99=all -qlanglvl=extc99 +for ac_arg in '' -std=gnu99 -std=c99 -c99 -AC99 -D_STDC_C99= -qlanglvl=extc99 do CC="$ac_save_CC $ac_arg" - rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then + if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c99=$ac_arg -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c99" != "xno" && break done @@ -3325,36 +3754,31 @@ fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c99" in x) - { $as_echo "$as_me:$LINENO: result: none needed" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) - { $as_echo "$as_me:$LINENO: result: unsupported" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c99" - { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c99" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 $as_echo "$ac_cv_prog_cc_c99" >&6; } ;; esac -if test "x$ac_cv_prog_cc_c99" != xno; then +if test "x$ac_cv_prog_cc_c99" != xno; then : ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 else - { $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } -if test "${ac_cv_prog_cc_c89+set}" = set; then +if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include -#include -#include +struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); @@ -3406,32 +3830,9 @@ for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" - rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then + if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done @@ -3442,47 +3843,45 @@ fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) - { $as_echo "$as_me:$LINENO: result: none needed" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) - { $as_echo "$as_me:$LINENO: result: unsupported" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" - { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac -if test "x$ac_cv_prog_cc_c89" != xno; then +if test "x$ac_cv_prog_cc_c89" != xno; then : ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 else ac_cv_prog_cc_stdc=no fi - fi - ;; esac - { $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO Standard C" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO Standard C" >&5 $as_echo_n "checking for $CC option to accept ISO Standard C... " >&6; } - if test "${ac_cv_prog_cc_stdc+set}" = set; then + if ${ac_cv_prog_cc_stdc+:} false; then : $as_echo_n "(cached) " >&6 fi - case $ac_cv_prog_cc_stdc in - no) { $as_echo "$as_me:$LINENO: result: unsupported" >&5 -$as_echo "unsupported" >&6; } ;; - '') { $as_echo "$as_me:$LINENO: result: none needed" >&5 -$as_echo "none needed" >&6; } ;; - *) { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 + case $ac_cv_prog_cc_stdc in #( + no) : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; #( + '') : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; #( + *) : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_stdc" >&5 $as_echo "$ac_cv_prog_cc_stdc" >&6; } ;; esac - if test "x$ac_cv_prog_cc_stdc" == "xno" ; then - { { $as_echo "$as_me:$LINENO: error: Problem : Need a C99 compiler ! " >&5 -$as_echo "$as_me: error: Problem : Need a C99 compiler ! " >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Problem : Need a C99 compiler ! " "$LINENO" 5 else C99OPT="$ac_cv_prog_cc_stdc"; fi @@ -3495,10 +3894,10 @@ fi # Note: Someday we will contemplate a fake MPI - configured version of PSBLAS ############################################################################### # First check whether the user required our serial (fake) mpi. -{ $as_echo "$as_me:$LINENO: checking whether we want serial mpi stubs" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we want serial mpi stubs" >&5 $as_echo_n "checking whether we want serial mpi stubs... " >&6; } # Check whether --enable-serial was given. -if test "${enable_serial+set}" = set; then +if test "${enable_serial+set}" = set; then : enableval=$enable_serial; pac_cv_serial_mpi="yes"; @@ -3506,11 +3905,11 @@ pac_cv_serial_mpi="yes"; fi if test x"$pac_cv_serial_mpi" == x"yes" ; then - { $as_echo "$as_me:$LINENO: result: yes." >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes." >&5 $as_echo "yes." >&6; } else pac_cv_serial_mpi="no"; - { $as_echo "$as_me:$LINENO: result: no." >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no." >&5 $as_echo "no." >&6; } fi @@ -3534,9 +3933,9 @@ if test "X$MPICC" = "X" ; then do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_MPICC+set}" = set; then +if ${ac_cv_prog_MPICC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MPICC"; then @@ -3547,24 +3946,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MPICC="$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi MPICC=$ac_cv_prog_MPICC if test -n "$MPICC"; then - { $as_echo "$as_me:$LINENO: result: $MPICC" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MPICC" >&5 $as_echo "$MPICC" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -3583,9 +3982,9 @@ fi do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_MPICC+set}" = set; then +if ${ac_cv_prog_MPICC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MPICC"; then @@ -3596,24 +3995,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MPICC="$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi MPICC=$ac_cv_prog_MPICC if test -n "$MPICC"; then - { $as_echo "$as_me:$LINENO: result: $MPICC" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MPICC" >&5 $as_echo "$MPICC" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -3628,110 +4027,22 @@ test -n "$MPICC" || MPICC="$CC" if test x = x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for MPI_Init" >&5 -$as_echo_n "checking for MPI_Init... " >&6; } -if test "${ac_cv_func_MPI_Init+set}" = set; then - $as_echo_n "(cached) " >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define MPI_Init to an innocuous variant, in case declares MPI_Init. - For example, HP-UX 11i declares gettimeofday. */ -#define MPI_Init innocuous_MPI_Init - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char MPI_Init (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef MPI_Init - -/* Override any GCC internal prototype to avoid an error. - Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. */ -#ifdef __cplusplus -extern "C" -#endif -char MPI_Init (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined __stub_MPI_Init || defined __stub___MPI_Init -choke me -#endif - -int -main () -{ -return MPI_Init (); - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then - ac_cv_func_MPI_Init=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_func_MPI_Init=no -fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_func_MPI_Init" >&5 -$as_echo "$ac_cv_func_MPI_Init" >&6; } -if test "x$ac_cv_func_MPI_Init" = x""yes; then + ac_fn_c_check_func "$LINENO" "MPI_Init" "ac_cv_func_MPI_Init" +if test "x$ac_cv_func_MPI_Init" = xyes; then : MPILIBS=" " fi fi if test x = x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for MPI_Init in -lmpi" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpi" >&5 $as_echo_n "checking for MPI_Init in -lmpi... " >&6; } -if test "${ac_cv_lib_mpi_MPI_Init+set}" = set; then +if ${ac_cv_lib_mpi_MPI_Init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpi $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -3749,60 +4060,31 @@ return MPI_Init (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mpi_MPI_Init=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_mpi_MPI_Init=no + ac_cv_lib_mpi_MPI_Init=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_mpi_MPI_Init" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpi_MPI_Init" >&5 $as_echo "$ac_cv_lib_mpi_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpi_MPI_Init" = x""yes; then +if test "x$ac_cv_lib_mpi_MPI_Init" = xyes; then : MPILIBS="-lmpi" fi fi if test x = x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for MPI_Init in -lmpich" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpich" >&5 $as_echo_n "checking for MPI_Init in -lmpich... " >&6; } -if test "${ac_cv_lib_mpich_MPI_Init+set}" = set; then +if ${ac_cv_lib_mpich_MPI_Init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpich $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -3820,56 +4102,27 @@ return MPI_Init (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_mpich_MPI_Init=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_mpich_MPI_Init=no + ac_cv_lib_mpich_MPI_Init=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_mpich_MPI_Init" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpich_MPI_Init" >&5 $as_echo "$ac_cv_lib_mpich_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpich_MPI_Init" = x""yes; then +if test "x$ac_cv_lib_mpich_MPI_Init" = xyes; then : MPILIBS="-lmpich" fi fi if test x != x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for mpi.h" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpi.h" >&5 $as_echo_n "checking for mpi.h... " >&6; } - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int @@ -3880,35 +4133,14 @@ main () return 0; } _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_c_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - MPILIBS="" - { $as_echo "$as_me:$LINENO: result: no" >&5 + MPILIBS="" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi @@ -3918,33 +4150,27 @@ CC="$acx_mpi_save_CC" # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: if test x = x"$MPILIBS"; then - { { $as_echo "$as_me:$LINENO: error: Cannot find any suitable MPI implementation for C" >&5 -$as_echo "$as_me: error: Cannot find any suitable MPI implementation for C" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Cannot find any suitable MPI implementation for C" "$LINENO" 5 : else -cat >>confdefs.h <<\_ACEOF -#define HAVE_MPI 1 -_ACEOF +$as_echo "#define HAVE_MPI 1" >>confdefs.h : fi - case $ac_cv_prog_cc_stdc in - no) ac_cv_prog_cc_c99=no; ac_cv_prog_cc_c89=no ;; - *) { $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO C99" >&5 + case $ac_cv_prog_cc_stdc in #( + no) : + ac_cv_prog_cc_c99=no; ac_cv_prog_cc_c89=no ;; #( + *) : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C99" >&5 $as_echo_n "checking for $CC option to accept ISO C99... " >&6; } -if test "${ac_cv_prog_cc_c99+set}" = set; then +if ${ac_cv_prog_cc_c99+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c99=no ac_save_CC=$CC -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include @@ -4083,35 +4309,12 @@ main () return 0; } _ACEOF -for ac_arg in '' -std=gnu99 -std=c99 -c99 -AC99 -xc99=all -qlanglvl=extc99 +for ac_arg in '' -std=gnu99 -std=c99 -c99 -AC99 -D_STDC_C99= -qlanglvl=extc99 do CC="$ac_save_CC $ac_arg" - rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then + if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c99=$ac_arg -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c99" != "xno" && break done @@ -4122,36 +4325,31 @@ fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c99" in x) - { $as_echo "$as_me:$LINENO: result: none needed" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) - { $as_echo "$as_me:$LINENO: result: unsupported" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c99" - { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c99" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 $as_echo "$ac_cv_prog_cc_c99" >&6; } ;; esac -if test "x$ac_cv_prog_cc_c99" != xno; then +if test "x$ac_cv_prog_cc_c99" != xno; then : ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 else - { $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO C89" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } -if test "${ac_cv_prog_cc_c89+set}" = set; then +if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include -#include -#include +struct stat; /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); @@ -4203,32 +4401,9 @@ for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" - rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then + if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done @@ -4239,44 +4414,44 @@ fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) - { $as_echo "$as_me:$LINENO: result: none needed" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) - { $as_echo "$as_me:$LINENO: result: unsupported" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" - { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_c89" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac -if test "x$ac_cv_prog_cc_c89" != xno; then +if test "x$ac_cv_prog_cc_c89" != xno; then : ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 else ac_cv_prog_cc_stdc=no fi - fi - ;; esac - { $as_echo "$as_me:$LINENO: checking for $CC option to accept ISO Standard C" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO Standard C" >&5 $as_echo_n "checking for $CC option to accept ISO Standard C... " >&6; } - if test "${ac_cv_prog_cc_stdc+set}" = set; then + if ${ac_cv_prog_cc_stdc+:} false; then : $as_echo_n "(cached) " >&6 fi - case $ac_cv_prog_cc_stdc in - no) { $as_echo "$as_me:$LINENO: result: unsupported" >&5 -$as_echo "unsupported" >&6; } ;; - '') { $as_echo "$as_me:$LINENO: result: none needed" >&5 -$as_echo "none needed" >&6; } ;; - *) { $as_echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 + case $ac_cv_prog_cc_stdc in #( + no) : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; #( + '') : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; #( + *) : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_stdc" >&5 $as_echo "$ac_cv_prog_cc_stdc" >&6; } ;; esac - ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' @@ -4289,9 +4464,9 @@ if test "X$MPIFC" = "X" ; then do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_MPIFC+set}" = set; then +if ${ac_cv_prog_MPIFC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MPIFC"; then @@ -4302,24 +4477,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MPIFC="$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi MPIFC=$ac_cv_prog_MPIFC if test -n "$MPIFC"; then - { $as_echo "$as_me:$LINENO: result: $MPIFC" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MPIFC" >&5 $as_echo "$MPIFC" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -4339,9 +4514,9 @@ fi do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_MPIFC+set}" = set; then +if ${ac_cv_prog_MPIFC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MPIFC"; then @@ -4352,24 +4527,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MPIFC="$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi MPIFC=$ac_cv_prog_MPIFC if test -n "$MPIFC"; then - { $as_echo "$as_me:$LINENO: result: $MPIFC" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MPIFC" >&5 $as_echo "$MPIFC" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -4384,305 +4559,159 @@ test -n "$MPIFC" || MPIFC="$FC" if test x = x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for MPI_Init" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init" >&5 $as_echo_n "checking for MPI_Init... " >&6; } - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main call MPI_Init end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : MPILIBS=" " - { $as_echo "$as_me:$LINENO: result: yes" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi if test x = x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for MPI_Init in -lfmpi" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lfmpi" >&5 $as_echo_n "checking for MPI_Init in -lfmpi... " >&6; } -if test "${ac_cv_lib_fmpi_MPI_Init+set}" = set; then +if ${ac_cv_lib_fmpi_MPI_Init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lfmpi $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call MPI_Init end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_fmpi_MPI_Init=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_fmpi_MPI_Init=no + ac_cv_lib_fmpi_MPI_Init=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_fmpi_MPI_Init" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_fmpi_MPI_Init" >&5 $as_echo "$ac_cv_lib_fmpi_MPI_Init" >&6; } -if test "x$ac_cv_lib_fmpi_MPI_Init" = x""yes; then +if test "x$ac_cv_lib_fmpi_MPI_Init" = xyes; then : MPILIBS="-lfmpi" fi fi if test x = x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for MPI_Init in -lmpichf90" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpichf90" >&5 $as_echo_n "checking for MPI_Init in -lmpichf90... " >&6; } -if test "${ac_cv_lib_mpichf90_MPI_Init+set}" = set; then +if ${ac_cv_lib_mpichf90_MPI_Init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpichf90 $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call MPI_Init end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_mpichf90_MPI_Init=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_mpichf90_MPI_Init=no + ac_cv_lib_mpichf90_MPI_Init=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_mpichf90_MPI_Init" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpichf90_MPI_Init" >&5 $as_echo "$ac_cv_lib_mpichf90_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpichf90_MPI_Init" = x""yes; then +if test "x$ac_cv_lib_mpichf90_MPI_Init" = xyes; then : MPILIBS="-lmpichf90" fi fi if test x = x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for MPI_Init in -lmpi" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpi" >&5 $as_echo_n "checking for MPI_Init in -lmpi... " >&6; } -if test "${ac_cv_lib_mpi_MPI_Init+set}" = set; then +if ${ac_cv_lib_mpi_MPI_Init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpi $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call MPI_Init end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_mpi_MPI_Init=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_mpi_MPI_Init=no + ac_cv_lib_mpi_MPI_Init=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_mpi_MPI_Init" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpi_MPI_Init" >&5 $as_echo "$ac_cv_lib_mpi_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpi_MPI_Init" = x""yes; then +if test "x$ac_cv_lib_mpi_MPI_Init" = xyes; then : MPILIBS="-lmpi" fi fi if test x = x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for MPI_Init in -lmpich" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for MPI_Init in -lmpich" >&5 $as_echo_n "checking for MPI_Init in -lmpich... " >&6; } -if test "${ac_cv_lib_mpich_MPI_Init+set}" = set; then +if ${ac_cv_lib_mpich_MPI_Init+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmpich $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call MPI_Init end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_mpich_MPI_Init=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_mpich_MPI_Init=no + ac_cv_lib_mpich_MPI_Init=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_mpich_MPI_Init" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mpich_MPI_Init" >&5 $as_echo "$ac_cv_lib_mpich_MPI_Init" >&6; } -if test "x$ac_cv_lib_mpich_MPI_Init" = x""yes; then +if test "x$ac_cv_lib_mpich_MPI_Init" = xyes; then : MPILIBS="-lmpich" fi fi if test x != x"$MPILIBS"; then - { $as_echo "$as_me:$LINENO: checking for mpif.h" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mpif.h" >&5 $as_echo_n "checking for mpif.h... " >&6; } - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main include 'mpif.h' end _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - MPILIBS="" - { $as_echo "$as_me:$LINENO: result: no" >&5 + MPILIBS="" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi @@ -4692,15 +4721,11 @@ FC="$acx_mpi_save_FC" # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: if test x = x"$MPILIBS"; then - { { $as_echo "$as_me:$LINENO: error: Cannot find any suitable MPI implementation for Fortran" >&5 -$as_echo "$as_me: error: Cannot find any suitable MPI implementation for Fortran" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Cannot find any suitable MPI implementation for Fortran" "$LINENO" 5 : else -cat >>confdefs.h <<\_ACEOF -#define HAVE_MPI 1 -_ACEOF +$as_echo "#define HAVE_MPI 1" >>confdefs.h : fi @@ -4723,15 +4748,11 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu ############################################################################### if test "X$MPIFC" == "X" ; then - { { $as_echo "$as_me:$LINENO: error: Problem : No MPI Fortran compiler specified nor found!" >&5 -$as_echo "$as_me: error: Problem : No MPI Fortran compiler specified nor found!" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Problem : No MPI Fortran compiler specified nor found!" "$LINENO" 5 fi if test "X$MPICC" == "X" ; then - { { $as_echo "$as_me:$LINENO: error: Problem : No MPI C compiler specified nor found!" >&5 -$as_echo "$as_me: error: Problem : No MPI C compiler specified nor found!" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Problem : No MPI C compiler specified nor found!" "$LINENO" 5 fi ############################################################################### @@ -4739,54 +4760,54 @@ fi ############################################################################### -{ $as_echo "$as_me:$LINENO: checking whether additional CCOPT flags should be added (should be invoked only once)" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional CCOPT flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional CCOPT flags should be added (should be invoked only once)... " >&6; } # Check whether --with-ccopt was given. -if test "${with_ccopt+set}" = set; then +if test "${with_ccopt+set}" = set; then : withval=$with_ccopt; CCOPT="${withval} ${CCOPT}" -{ $as_echo "$as_me:$LINENO: result: CCOPT = ${CCOPT}" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: CCOPT = ${CCOPT}" >&5 $as_echo "CCOPT = ${CCOPT}" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi -{ $as_echo "$as_me:$LINENO: checking whether additional FCOPT flags should be added (should be invoked only once)" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional FCOPT flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional FCOPT flags should be added (should be invoked only once)... " >&6; } # Check whether --with-fcopt was given. -if test "${with_fcopt+set}" = set; then +if test "${with_fcopt+set}" = set; then : withval=$with_fcopt; FCOPT="${withval} ${FCOPT}" -{ $as_echo "$as_me:$LINENO: result: FCOPT = ${FCOPT}" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: FCOPT = ${FCOPT}" >&5 $as_echo "FCOPT = ${FCOPT}" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi -{ $as_echo "$as_me:$LINENO: checking whether additional libraries are needed" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional libraries are needed" >&5 $as_echo_n "checking whether additional libraries are needed... " >&6; } # Check whether --with-libs was given. -if test "${with_libs+set}" = set; then +if test "${with_libs+set}" = set; then : withval=$with_libs; LIBS="${withval} ${LIBS}" -{ $as_echo "$as_me:$LINENO: result: LIBS = ${LIBS}" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: LIBS = ${LIBS}" >&5 $as_echo "LIBS = ${LIBS}" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -4794,36 +4815,36 @@ fi -{ $as_echo "$as_me:$LINENO: checking whether additional CLIBS flags should be added (should be invoked only once)" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional CLIBS flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional CLIBS flags should be added (should be invoked only once)... " >&6; } # Check whether --with-clibs was given. -if test "${with_clibs+set}" = set; then +if test "${with_clibs+set}" = set; then : withval=$with_clibs; CLIBS="${withval} ${CLIBS}" -{ $as_echo "$as_me:$LINENO: result: CLIBS = ${CLIBS}" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: CLIBS = ${CLIBS}" >&5 $as_echo "CLIBS = ${CLIBS}" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi -{ $as_echo "$as_me:$LINENO: checking whether additional FLIBS flags should be added (should be invoked only once)" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional FLIBS flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional FLIBS flags should be added (should be invoked only once)... " >&6; } # Check whether --with-flibs was given. -if test "${with_flibs+set}" = set; then +if test "${with_flibs+set}" = set; then : withval=$with_flibs; FLIBS="${withval} ${FLIBS}" -{ $as_echo "$as_me:$LINENO: result: FLIBS = ${FLIBS}" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: FLIBS = ${FLIBS}" >&5 $as_echo "FLIBS = ${FLIBS}" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -4831,54 +4852,54 @@ fi -{ $as_echo "$as_me:$LINENO: checking whether additional LIBRARYPATH flags should be added (should be invoked only once)" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional LIBRARYPATH flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional LIBRARYPATH flags should be added (should be invoked only once)... " >&6; } # Check whether --with-library-path was given. -if test "${with_library_path+set}" = set; then +if test "${with_library_path+set}" = set; then : withval=$with_library_path; LIBRARYPATH="${withval} ${LIBRARYPATH}" -{ $as_echo "$as_me:$LINENO: result: LIBRARYPATH = ${LIBRARYPATH}" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: LIBRARYPATH = ${LIBRARYPATH}" >&5 $as_echo "LIBRARYPATH = ${LIBRARYPATH}" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi -{ $as_echo "$as_me:$LINENO: checking whether additional INCLUDEPATH flags should be added (should be invoked only once)" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional INCLUDEPATH flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional INCLUDEPATH flags should be added (should be invoked only once)... " >&6; } # Check whether --with-include-path was given. -if test "${with_include_path+set}" = set; then +if test "${with_include_path+set}" = set; then : withval=$with_include_path; INCLUDEPATH="${withval} ${INCLUDEPATH}" -{ $as_echo "$as_me:$LINENO: result: INCLUDEPATH = ${INCLUDEPATH}" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: INCLUDEPATH = ${INCLUDEPATH}" >&5 $as_echo "INCLUDEPATH = ${INCLUDEPATH}" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi -{ $as_echo "$as_me:$LINENO: checking whether additional MODULE_PATH flags should be added (should be invoked only once)" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether additional MODULE_PATH flags should be added (should be invoked only once)" >&5 $as_echo_n "checking whether additional MODULE_PATH flags should be added (should be invoked only once)... " >&6; } # Check whether --with-module-path was given. -if test "${with_module_path+set}" = set; then +if test "${with_module_path+set}" = set; then : withval=$with_module_path; MODULE_PATH="${withval} ${MODULE_PATH}" -{ $as_echo "$as_me:$LINENO: result: MODULE_PATH = ${MODULE_PATH}" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: MODULE_PATH = ${MODULE_PATH}" >&5 $as_echo "MODULE_PATH = ${MODULE_PATH}" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -4893,9 +4914,9 @@ fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_RANLIB+set}" = set; then +if ${ac_cv_prog_RANLIB+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$RANLIB"; then @@ -4906,24 +4927,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then - { $as_echo "$as_me:$LINENO: result: $RANLIB" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 $as_echo "$RANLIB" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -4933,9 +4954,9 @@ if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then +if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_RANLIB"; then @@ -4946,24 +4967,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_RANLIB="ranlib" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then - { $as_echo "$as_me:$LINENO: result: $ac_ct_RANLIB" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 $as_echo "$ac_ct_RANLIB" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -4972,7 +4993,7 @@ fi else case $cross_compiling:$ac_tool_warned in yes:) -{ $as_echo "$as_me:$LINENO: WARNING: using cross tools not prefixed with host triplet" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac @@ -4983,70 +5004,75 @@ else fi -am__api_version='1.11' +am__api_version='1.15' -{ $as_echo "$as_me:$LINENO: checking whether build environment is sane" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether build environment is sane" >&5 $as_echo_n "checking whether build environment is sane... " >&6; } -# Just in case -sleep 1 -echo timestamp > conftest.file # Reject unsafe characters in $srcdir or the absolute working directory # name. Accept space and tab only in the latter. am_lf=' ' case `pwd` in *[\\\"\#\$\&\'\`$am_lf]*) - { { $as_echo "$as_me:$LINENO: error: unsafe absolute working directory name" >&5 -$as_echo "$as_me: error: unsafe absolute working directory name" >&2;} - { (exit 1); exit 1; }; };; + as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; esac case $srcdir in *[\\\"\#\$\&\'\`$am_lf\ \ ]*) - { { $as_echo "$as_me:$LINENO: error: unsafe srcdir value: \`$srcdir'" >&5 -$as_echo "$as_me: error: unsafe srcdir value: \`$srcdir'" >&2;} - { (exit 1); exit 1; }; };; + as_fn_error $? "unsafe srcdir value: '$srcdir'" "$LINENO" 5;; esac -# Do `set' in a subshell so we don't clobber the current shell's +# Do 'set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). if ( - set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` - if test "$*" = "X"; then - # -L didn't work. - set X `ls -t "$srcdir/configure" conftest.file` - fi - rm -f conftest.file - if test "$*" != "X $srcdir/configure conftest.file" \ - && test "$*" != "X conftest.file $srcdir/configure"; then - - # If neither matched, then we have a broken ls. This can happen - # if, for instance, CONFIG_SHELL is bash and it inherits a - # broken ls alias from the environment. This has actually - # happened. Such a system could not be considered "sane". - { { $as_echo "$as_me:$LINENO: error: ls -t appears to fail. Make sure there is not a broken -alias in your environment" >&5 -$as_echo "$as_me: error: ls -t appears to fail. Make sure there is not a broken -alias in your environment" >&2;} - { (exit 1); exit 1; }; } - fi + am_has_slept=no + for am_try in 1 2; do + echo "timestamp, slept: $am_has_slept" > conftest.file + set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` + if test "$*" = "X"; then + # -L didn't work. + set X `ls -t "$srcdir/configure" conftest.file` + fi + if test "$*" != "X $srcdir/configure conftest.file" \ + && test "$*" != "X conftest.file $srcdir/configure"; then + # If neither matched, then we have a broken ls. This can happen + # if, for instance, CONFIG_SHELL is bash and it inherits a + # broken ls alias from the environment. This has actually + # happened. Such a system could not be considered "sane". + as_fn_error $? "ls -t appears to fail. Make sure there is not a broken + alias in your environment" "$LINENO" 5 + fi + if test "$2" = conftest.file || test $am_try -eq 2; then + break + fi + # Just in case. + sleep 1 + am_has_slept=yes + done test "$2" = conftest.file ) then # Ok. : else - { { $as_echo "$as_me:$LINENO: error: newly created file is older than distributed files! -Check your system clock" >&5 -$as_echo "$as_me: error: newly created file is older than distributed files! -Check your system clock" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "newly created file is older than distributed files! +Check your system clock" "$LINENO" 5 fi -{ $as_echo "$as_me:$LINENO: result: yes" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } +# If we didn't sleep, we still need to ensure time stamps of config.status and +# generated files are strictly newer. +am_sleep_pid= +if grep 'slept: no' conftest.file >/dev/null 2>&1; then + ( sleep 1 ) & + am_sleep_pid=$! +fi + +rm -f conftest.file + test "$program_prefix" != NONE && program_transform_name="s&^&$program_prefix&;$program_transform_name" # Use a double $ so make ignores it. @@ -5057,9 +5083,6 @@ test "$program_suffix" != NONE && ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"` -# expand $ac_aux_dir to an absolute path -am_aux_dir=`cd $ac_aux_dir && pwd` - if test x"${MISSING+set}" != xset; then case $am_aux_dir in *\ * | *\ *) @@ -5069,15 +5092,15 @@ if test x"${MISSING+set}" != xset; then esac fi # Use eval to expand $SHELL -if eval "$MISSING --run true"; then - am_missing_run="$MISSING --run " +if eval "$MISSING --is-lightweight"; then + am_missing_run="$MISSING " else am_missing_run= - { $as_echo "$as_me:$LINENO: WARNING: \`missing' script is too old or missing" >&5 -$as_echo "$as_me: WARNING: \`missing' script is too old or missing" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 'missing' script is too old or missing" >&5 +$as_echo "$as_me: WARNING: 'missing' script is too old or missing" >&2;} fi -if test x"${install_sh}" != xset; then +if test x"${install_sh+set}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; @@ -5086,17 +5109,17 @@ if test x"${install_sh}" != xset; then esac fi -# Installed binaries are usually stripped using `strip' when the user -# run `make install-strip'. However `strip' might not be the right +# Installed binaries are usually stripped using 'strip' when the user +# run "make install-strip". However 'strip' might not be the right # tool to use in cross-compilation environments, therefore Automake -# will honor the `STRIP' environment variable to overrule this program. +# will honor the 'STRIP' environment variable to overrule this program. if test "$cross_compiling" != no; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. set dummy ${ac_tool_prefix}strip; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_STRIP+set}" = set; then +if ${ac_cv_prog_STRIP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$STRIP"; then @@ -5107,24 +5130,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_STRIP="${ac_tool_prefix}strip" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then - { $as_echo "$as_me:$LINENO: result: $STRIP" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 $as_echo "$STRIP" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -5134,9 +5157,9 @@ if test -z "$ac_cv_prog_STRIP"; then ac_ct_STRIP=$STRIP # Extract the first word of "strip", so it can be a program name with args. set dummy strip; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_ac_ct_STRIP+set}" = set; then +if ${ac_cv_prog_ac_ct_STRIP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_STRIP"; then @@ -5147,24 +5170,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_STRIP="strip" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then - { $as_echo "$as_me:$LINENO: result: $ac_ct_STRIP" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 $as_echo "$ac_ct_STRIP" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -5173,7 +5196,7 @@ fi else case $cross_compiling:$ac_tool_warned in yes:) -{ $as_echo "$as_me:$LINENO: WARNING: using cross tools not prefixed with host triplet" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac @@ -5186,10 +5209,10 @@ fi fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" -{ $as_echo "$as_me:$LINENO: checking for a thread-safe mkdir -p" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for a thread-safe mkdir -p" >&5 $as_echo_n "checking for a thread-safe mkdir -p... " >&6; } if test -z "$MKDIR_P"; then - if test "${ac_cv_path_mkdir+set}" = set; then + if ${ac_cv_path_mkdir+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -5197,9 +5220,9 @@ for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_prog in mkdir gmkdir; do + for ac_prog in mkdir gmkdir; do for ac_exec_ext in '' $ac_executable_extensions; do - { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; } || continue + as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext" || continue case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( 'mkdir (GNU coreutils) '* | \ 'mkdir (coreutils) '* | \ @@ -5209,11 +5232,12 @@ do esac done done -done + done IFS=$as_save_IFS fi + test -d ./--version && rmdir ./--version if test "${ac_cv_path_mkdir+set}" = set; then MKDIR_P="$ac_cv_path_mkdir -p" else @@ -5221,26 +5245,19 @@ fi # value for MKDIR_P within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. - test -d ./--version && rmdir ./--version MKDIR_P="$ac_install_sh -d" fi fi -{ $as_echo "$as_me:$LINENO: result: $MKDIR_P" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 $as_echo "$MKDIR_P" >&6; } -mkdir_p="$MKDIR_P" -case $mkdir_p in - [\\/$]* | ?:[\\/]*) ;; - */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;; -esac - for ac_prog in gawk mawk nawk awk do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:$LINENO: checking for $ac_word" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_prog_AWK+set}" = set; then +if ${ac_cv_prog_AWK+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$AWK"; then @@ -5251,24 +5268,24 @@ for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_AWK="$ac_prog" - $as_echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done -done + done IFS=$as_save_IFS fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then - { $as_echo "$as_me:$LINENO: result: $AWK" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 $as_echo "$AWK" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi @@ -5276,11 +5293,11 @@ fi test -n "$AWK" && break done -{ $as_echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` -if { as_var=ac_cv_prog_make_${ac_make}_set; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF @@ -5288,7 +5305,7 @@ SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF -# GNU make sometimes prints "make[1]: Entering...", which would confuse us. +# GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; @@ -5298,11 +5315,11 @@ esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi @@ -5328,14 +5345,14 @@ am__doit: .PHONY: am__doit END # If we don't find an include directive, just comment out the code. -{ $as_echo "$as_me:$LINENO: checking for style of include used by $am_make" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for style of include used by $am_make" >&5 $as_echo_n "checking for style of include used by $am_make... " >&6; } am__include="#" am__quote= _am_result=none # First try GNU make style include. echo "include confinc" > confmf -# Ignore all kinds of additional output from `make'. +# Ignore all kinds of additional output from 'make'. case `$am_make -s -f confmf 2> /dev/null` in #( *the\ am__doit\ target*) am__include=include @@ -5356,18 +5373,19 @@ if test "$am__include" = "#"; then fi -{ $as_echo "$as_me:$LINENO: result: $_am_result" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $_am_result" >&5 $as_echo "$_am_result" >&6; } rm -f confinc confmf # Check whether --enable-dependency-tracking was given. -if test "${enable_dependency_tracking+set}" = set; then +if test "${enable_dependency_tracking+set}" = set; then : enableval=$enable_dependency_tracking; fi if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' + am__nodep='_no' fi if test "x$enable_dependency_tracking" != xno; then AMDEP_TRUE= @@ -5378,15 +5396,52 @@ else fi +# Check whether --enable-silent-rules was given. +if test "${enable_silent_rules+set}" = set; then : + enableval=$enable_silent_rules; +fi + +case $enable_silent_rules in # ((( + yes) AM_DEFAULT_VERBOSITY=0;; + no) AM_DEFAULT_VERBOSITY=1;; + *) AM_DEFAULT_VERBOSITY=1;; +esac +am_make=${MAKE-make} +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $am_make supports nested variables" >&5 +$as_echo_n "checking whether $am_make supports nested variables... " >&6; } +if ${am_cv_make_support_nested_variables+:} false; then : + $as_echo_n "(cached) " >&6 +else + if $as_echo 'TRUE=$(BAR$(V)) +BAR0=false +BAR1=true +V=1 +am__doit: + @$(TRUE) +.PHONY: am__doit' | $am_make -f - >/dev/null 2>&1; then + am_cv_make_support_nested_variables=yes +else + am_cv_make_support_nested_variables=no +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_make_support_nested_variables" >&5 +$as_echo "$am_cv_make_support_nested_variables" >&6; } +if test $am_cv_make_support_nested_variables = yes; then + AM_V='$(V)' + AM_DEFAULT_V='$(AM_DEFAULT_VERBOSITY)' +else + AM_V=$AM_DEFAULT_VERBOSITY + AM_DEFAULT_V=$AM_DEFAULT_VERBOSITY +fi +AM_BACKSLASH='\' + if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." am__isrc=' -I$(srcdir)' # test to see if srcdir already configured if test -f $srcdir/config.status; then - { { $as_echo "$as_me:$LINENO: error: source directory already configured; run \"make distclean\" there first" >&5 -$as_echo "$as_me: error: source directory already configured; run \"make distclean\" there first" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5 fi fi @@ -5430,30 +5485,42 @@ AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} -# We need awk for the "check" target. The system "awk" is bad on -# some platforms. -# Always define AMTAR for backward compatibility. +# For better backward compatibility. To be removed once Automake 1.9.x +# dies out for good. For more background, see: +# +# +mkdir_p='$(MKDIR_P)' -AMTAR=${AMTAR-"${am_missing_run}tar"} +# We need awk for the "check" target (and possibly the TAP driver). The +# system "awk" is bad on some platforms. +# Always define AMTAR for backward compatibility. Yes, it's still used +# in the wild :-( We should find a proper way to deprecate it ... +AMTAR='$${TAR-tar}' + + +# We'll loop over all known methods to create a tar archive until one works. +_am_tools='gnutar pax cpio none' + +am__tar='$${TAR-tar} chof - "$$tardir"' am__untar='$${TAR-tar} xf -' -am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -' depcc="$CC" am_compiler_list= -{ $as_echo "$as_me:$LINENO: checking dependency style of $depcc" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } -if test "${am_cv_CC_dependencies_compiler_type+set}" = set; then +if ${am_cv_CC_dependencies_compiler_type+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up - # making a dummy file named `D' -- because `-MD' means `put the output - # in D'. + # making a dummy file named 'D' -- because '-MD' means "put the output + # in D". + rm -rf conftest.dir mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. @@ -5487,16 +5554,16 @@ else : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c - # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with - # Solaris 8's {/usr,}/bin/sh. - touch sub/conftst$i.h + # Using ": > sub/conftst$i.h" creates only sub/conftst1.h with + # Solaris 10 /bin/sh. + echo '/* dummy */' > sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf - # We check with `-c' and `-o' for the sake of the "dashmstdout" + # We check with '-c' and '-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly - # handle `-M -o', and we need to detect this. Also, some Intel - # versions had trouble with output in subdirs + # handle '-M -o', and we need to detect this. Also, some Intel + # versions had trouble with output in subdirs. am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in @@ -5505,16 +5572,16 @@ else test "$am__universal" = false || continue ;; nosideeffect) - # after this tag, mechanisms are not by side-effect, so they'll - # only be used when explicitly requested + # After this tag, mechanisms are not by side-effect, so they'll + # only be used when explicitly requested. if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; - msvisualcpp | msvcmsys) - # This compiler won't grok `-c -o', but also, the minuso test has + msvc7 | msvc7msys | msvisualcpp | msvcmsys) + # This compiler won't grok '-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} @@ -5553,7 +5620,7 @@ else fi fi -{ $as_echo "$as_me:$LINENO: result: $am_cv_CC_dependencies_compiler_type" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 $as_echo "$am_cv_CC_dependencies_compiler_type" >&6; } CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type @@ -5569,6 +5636,48 @@ fi +# POSIX will say in a future version that running "rm -f" with no argument +# is OK; and we want to be able to make that assumption in our Makefile +# recipes. So use an aggressive probe to check that the usage we want is +# actually supported "in the wild" to an acceptable degree. +# See automake bug#10828. +# To make any issue more visible, cause the running configure to be aborted +# by default if the 'rm' program in use doesn't match our expectations; the +# user can still override this though. +if rm -f && rm -fr && rm -rf; then : OK; else + cat >&2 <<'END' +Oops! + +Your 'rm' program seems unable to run without file operands specified +on the command line, even when the '-f' option is present. This is contrary +to the behaviour of most rm programs out there, and not conforming with +the upcoming POSIX standard: + +Please tell bug-automake@gnu.org about your system, including the value +of your $PATH and any error possibly output before this message. This +can help us improve future automake versions. + +END + if test x"$ACCEPT_INFERIOR_RM_PROGRAM" = x"yes"; then + echo 'Configuration will proceed anyway, since you have set the' >&2 + echo 'ACCEPT_INFERIOR_RM_PROGRAM variable to "yes"' >&2 + echo >&2 + else + cat >&2 <<'END' +Aborting the configuration process, to ensure you take notice of the issue. + +You can download and install GNU coreutils to get an 'rm' implementation +that behaves properly: . + +If you want to complete the configuration process using your problematic +'rm' anyway, export the environment variable ACCEPT_INFERIOR_RM_PROGRAM +to "yes", and re-run configure. + +END + as_fn_error $? "Your 'rm' program is bad, sorry." "$LINENO" 5 + fi +fi + @@ -5578,7 +5687,7 @@ fi psblas_cv_fc="" -{ $as_echo "$as_me:$LINENO: checking for GNU Fortran" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for GNU Fortran" >&5 $as_echo_n "checking for GNU Fortran... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -5588,7 +5697,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main #ifdef __GNUC__ @@ -5598,38 +5707,17 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu #endif end _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } psblas_cv_fc="gcc" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -5639,7 +5727,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking for Cray Fortran" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Cray Fortran" >&5 $as_echo_n "checking for Cray Fortran... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -5649,7 +5737,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main #ifdef _CRAYFTN @@ -5659,38 +5747,17 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu #endif end _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } psblas_cv_fc="cray" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -5731,12 +5798,12 @@ if test x"$psblas_cv_fc" == "x" ; then else psblas_cv_fc="" # unsupported MPI Fortran compiler - { $as_echo "$as_me:$LINENO: Unknown Fortran compiler, proceeding with fingers crossed !" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: Unknown Fortran compiler, proceeding with fingers crossed !" >&5 $as_echo "$as_me: Unknown Fortran compiler, proceeding with fingers crossed !" >&6;} fi fi if test "X$psblas_cv_fc" == "Xgcc" ; then -{ $as_echo "$as_me:$LINENO: checking for recent GNU Fortran" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for recent GNU Fortran" >&5 $as_echo_n "checking for recent GNU Fortran... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -5746,7 +5813,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main #if ( __GNUC__ >= 4 && __GNUC_MINOR__ >= 8 ) || ( __GNUC__ > 4 ) @@ -5756,43 +5823,20 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu #endif end _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } - { $as_echo "$as_me:$LINENO: Sorry, we require GNU Fortran version 4.8.4 or later." >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: Sorry, we require GNU Fortran version 4.8.4 or later." >&5 $as_echo "$as_me: Sorry, we require GNU Fortran version 4.8.4 or later." >&6;} echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Bailing out." >&5 -$as_echo "$as_me: error: Bailing out." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Bailing out." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -5820,14 +5864,14 @@ ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then - if test "${ac_cv_prog_CPP+set}" = set; then + if ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded @@ -5842,11 +5886,7 @@ do # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include @@ -5855,78 +5895,34 @@ cat >>conftest.$ac_ext <<_ACEOF #endif Syntax error _ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then - : -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 +if ac_fn_c_try_cpp "$LINENO"; then : +else # Broken: fails on valid input. continue fi - -rm -f conftest.err conftest.$ac_ext +rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then +if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - # Passes both tests. ac_preproc_ok=: break fi - -rm -f conftest.err conftest.$ac_ext +rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.err conftest.$ac_ext -if $ac_preproc_ok; then +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : break fi @@ -5938,7 +5934,7 @@ fi else ac_cv_prog_CPP=$CPP fi -{ $as_echo "$as_me:$LINENO: result: $CPP" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes @@ -5949,11 +5945,7 @@ do # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include @@ -5962,87 +5954,40 @@ cat >>conftest.$ac_ext <<_ACEOF #endif Syntax error _ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then - : -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 +if ac_fn_c_try_cpp "$LINENO"; then : +else # Broken: fails on valid input. continue fi - -rm -f conftest.err conftest.$ac_ext +rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then +if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - # Passes both tests. ac_preproc_ok=: break fi - -rm -f conftest.err conftest.$ac_ext +rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. -rm -f conftest.err conftest.$ac_ext -if $ac_preproc_ok; then - : +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + else - { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; }; } +as_fn_error $? "C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c @@ -6052,9 +5997,9 @@ ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking for grep that handles long lines and -e" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } -if test "${ac_cv_path_GREP+set}" = set; then +if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then @@ -6065,10 +6010,10 @@ for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_prog in grep ggrep; do + for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" - { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue + as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in @@ -6085,7 +6030,7 @@ case `"$ac_path_GREP" --version 2>&1` in $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - ac_count=`expr $ac_count + 1` + as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" @@ -6100,26 +6045,24 @@ esac $ac_path_GREP_found && break 3 done done -done + done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then - { { $as_echo "$as_me:$LINENO: error: no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5 -$as_echo "$as_me: error: no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_path_GREP" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" -{ $as_echo "$as_me:$LINENO: checking for egrep" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } -if test "${ac_cv_path_EGREP+set}" = set; then +if ${ac_cv_path_EGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 @@ -6133,10 +6076,10 @@ for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - for ac_prog in egrep; do + for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" - { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue + as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in @@ -6153,7 +6096,7 @@ case `"$ac_path_EGREP" --version 2>&1` in $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - ac_count=`expr $ac_count + 1` + as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" @@ -6168,12 +6111,10 @@ esac $ac_path_EGREP_found && break 3 done done -done + done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then - { { $as_echo "$as_me:$LINENO: error: no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&5 -$as_echo "$as_me: error: no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP @@ -6181,21 +6122,17 @@ fi fi fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_path_EGREP" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" -{ $as_echo "$as_me:$LINENO: checking for ANSI C header files" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } -if test "${ac_cv_header_stdc+set}" = set; then +if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include @@ -6210,48 +6147,23 @@ main () return 0; } _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_header_stdc=no + ac_cv_header_stdc=no fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "memchr" >/dev/null 2>&1; then - : + $EGREP "memchr" >/dev/null 2>&1; then : + else ac_cv_header_stdc=no fi @@ -6261,18 +6173,14 @@ fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP "free" >/dev/null 2>&1; then - : + $EGREP "free" >/dev/null 2>&1; then : + else ac_cv_header_stdc=no fi @@ -6282,14 +6190,10 @@ fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. - if test "$cross_compiling" = yes; then + if test "$cross_compiling" = yes; then : : else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include @@ -6316,118 +6220,33 @@ main () return 0; } _ACEOF -rm -f conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - : +if ac_fn_c_try_run "$LINENO"; then : + else - $as_echo "$as_me: program exited with status $ac_status" >&5 -$as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -ac_cv_header_stdc=no + ac_cv_header_stdc=no fi -rm -rf conftest.dSYM -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext fi - fi fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then -cat >>confdefs.h <<\_ACEOF -#define STDC_HEADERS 1 -_ACEOF +$as_echo "#define STDC_HEADERS 1" >>confdefs.h fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. - - - - - - - - - for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h -do -as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 -$as_echo_n "checking for $ac_header... " >&6; } -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default - -#include <$ac_header> -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - eval "$as_ac_Header=yes" -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Header=no" -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -ac_res=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default +" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF @@ -6441,352 +6260,26 @@ done # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects # declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. -{ $as_echo "$as_me:$LINENO: checking size of void *" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking size of void *" >&5 $as_echo_n "checking size of void *... " >&6; } -if test "${ac_cv_sizeof_void_p+set}" = set; then +if ${ac_cv_sizeof_void_p+:} false; then : $as_echo_n "(cached) " >&6 else - if test "$cross_compiling" = yes; then - # Depending upon the size, compute the lo and hi bounds. -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ -static int test_array [1 - 2 * !(((long int) (sizeof (void *))) >= 0)]; -test_array [0] = 0 + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (void *))" "ac_cv_sizeof_void_p" "$ac_includes_default"; then : - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_lo=0 ac_mid=0 - while :; do - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ -static int test_array [1 - 2 * !(((long int) (sizeof (void *))) <= $ac_mid)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_hi=$ac_mid; break else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_lo=`expr $ac_mid + 1` - if test $ac_lo -le $ac_mid; then - ac_lo= ac_hi= - break - fi - ac_mid=`expr 2 '*' $ac_mid + 1` -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - done -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ -static int test_array [1 - 2 * !(((long int) (sizeof (void *))) < 0)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_hi=-1 ac_mid=-1 - while :; do - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ -static int test_array [1 - 2 * !(((long int) (sizeof (void *))) >= $ac_mid)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_lo=$ac_mid; break -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_hi=`expr '(' $ac_mid ')' - 1` - if test $ac_mid -le $ac_hi; then - ac_lo= ac_hi= - break - fi - ac_mid=`expr 2 '*' $ac_mid` -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - done -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_lo= ac_hi= -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -# Binary search between lo and hi bounds. -while test "x$ac_lo" != "x$ac_hi"; do - ac_mid=`expr '(' $ac_hi - $ac_lo ')' / 2 + $ac_lo` - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -int -main () -{ -static int test_array [1 - 2 * !(((long int) (sizeof (void *))) <= $ac_mid)]; -test_array [0] = 0 - - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_hi=$ac_mid -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_lo=`expr '(' $ac_mid ')' + 1` -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -done -case $ac_lo in -?*) ac_cv_sizeof_void_p=$ac_lo;; -'') if test "$ac_cv_type_void_p" = yes; then - { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + if test "$ac_cv_type_void_p" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: cannot compute sizeof (void *) -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: cannot compute sizeof (void *) -See \`config.log' for more details." >&2;} - { (exit 77); exit 77; }; }; } - else - ac_cv_sizeof_void_p=0 - fi ;; -esac -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -static long int longval () { return (long int) (sizeof (void *)); } -static unsigned long int ulongval () { return (long int) (sizeof (void *)); } -#include -#include -int -main () -{ - - FILE *f = fopen ("conftest.val", "w"); - if (! f) - return 1; - if (((long int) (sizeof (void *))) < 0) - { - long int i = longval (); - if (i != ((long int) (sizeof (void *)))) - return 1; - fprintf (f, "%ld", i); - } - else - { - unsigned long int i = ulongval (); - if (i != ((long int) (sizeof (void *)))) - return 1; - fprintf (f, "%lu", i); - } - /* Do not output a trailing newline, as this causes \r\n confusion - on some platforms. */ - return ferror (f) || fclose (f) != 0; - - ; - return 0; -} -_ACEOF -rm -f conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { ac_try='./conftest$ac_exeext' - { (case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_try") 2>&5 - ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - ac_cv_sizeof_void_p=`cat conftest.val` -else - $as_echo "$as_me: program exited with status $ac_status" >&5 -$as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -( exit $ac_status ) -if test "$ac_cv_type_void_p" = yes; then - { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 -$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: cannot compute sizeof (void *) -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: cannot compute sizeof (void *) -See \`config.log' for more details." >&2;} - { (exit 77); exit 77; }; }; } +as_fn_error 77 "cannot compute sizeof (void *) +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_void_p=0 fi fi -rm -rf conftest.dSYM -rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext + fi -rm -f conftest.val -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_sizeof_void_p" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_void_p" >&5 $as_echo "$ac_cv_sizeof_void_p" >&6; } @@ -6805,12 +6298,12 @@ ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_fc_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking for Fortran name-mangling scheme" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran name-mangling scheme" >&5 $as_echo_n "checking for Fortran name-mangling scheme... " >&6; } -if test "${ac_cv_fc_mangling+set}" = set; then +if ${ac_cv_fc_mangling+:} false; then : $as_echo_n "(cached) " >&6 else - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF subroutine foobar() return end @@ -6818,24 +6311,7 @@ else return end _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_fc_try_compile "$LINENO"; then : mv conftest.$ac_objext cfortran_test.$ac_objext ac_save_LIBS=$LIBS @@ -6850,11 +6326,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu for ac_foobar in foobar FOOBAR; do for ac_underscore in "" "_"; do ac_func="$ac_foobar$ac_underscore" - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -6872,38 +6344,11 @@ return $ac_func (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : ac_success=yes; break 2 -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext done done ac_ext=${ac_fc_srcext-f} @@ -6931,11 +6376,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_success_extra=no for ac_extra in "" "_"; do ac_func="$ac_foo_bar$ac_underscore$ac_extra" - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -6953,38 +6394,11 @@ return $ac_func (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : ac_success_extra=yes; break -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext done ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -6993,16 +6407,16 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu if test "$ac_success_extra" = "yes"; then ac_cv_fc_mangling="$ac_case case" - if test -z "$ac_underscore"; then - ac_cv_fc_mangling="$ac_cv_fc_mangling, no underscore" + if test -z "$ac_underscore"; then + ac_cv_fc_mangling="$ac_cv_fc_mangling, no underscore" else - ac_cv_fc_mangling="$ac_cv_fc_mangling, underscore" - fi - if test -z "$ac_extra"; then - ac_cv_fc_mangling="$ac_cv_fc_mangling, no extra underscore" + ac_cv_fc_mangling="$ac_cv_fc_mangling, underscore" + fi + if test -z "$ac_extra"; then + ac_cv_fc_mangling="$ac_cv_fc_mangling, no extra underscore" else - ac_cv_fc_mangling="$ac_cv_fc_mangling, extra underscore" - fi + ac_cv_fc_mangling="$ac_cv_fc_mangling, extra underscore" + fi else ac_cv_fc_mangling="unknown" fi @@ -7014,22 +6428,15 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu rm -rf conftest* rm -f cfortran_test* else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { { $as_echo "$as_me:$LINENO: error: in \`$ac_pwd':" >&5 + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -{ { $as_echo "$as_me:$LINENO: error: cannot compile a simple Fortran program -See \`config.log' for more details." >&5 -$as_echo "$as_me: error: cannot compile a simple Fortran program -See \`config.log' for more details." >&2;} - { (exit 1); exit 1; }; }; } +as_fn_error $? "cannot compile a simple Fortran program +See \`config.log' for more details" "$LINENO" 5; } fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_fc_mangling" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_fc_mangling" >&5 $as_echo "$ac_cv_fc_mangling" >&6; } if test "X$psblas_cv_fc" == X"pg" ; then @@ -7047,7 +6454,7 @@ pac_fc_sec_under=${pac_fc_under#*,} pac_fc_sec_under=${pac_fc_sec_under# } pac_fc_under=${pac_fc_under%%,*} pac_fc_under=${pac_fc_under# } -{ $as_echo "$as_me:$LINENO: checking defines for C/Fortran name interfaces" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking defines for C/Fortran name interfaces" >&5 $as_echo_n "checking defines for C/Fortran name interfaces... " >&6; } if test "x$pac_fc_case" == "xlower case"; then if test "x$pac_fc_under" == "xunderscore"; then @@ -7082,7 +6489,7 @@ else fi CDEFINES="$pac_f_c_names $CDEFINES" -{ $as_echo "$as_me:$LINENO: result: $pac_f_c_names " >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_f_c_names " >&5 $as_echo " $pac_f_c_names " >&6; } ############################################################################### @@ -7201,9 +6608,9 @@ then else -{ $as_echo "$as_me:$LINENO: checking fortran 90 modules extension" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking fortran 90 modules extension" >&5 $as_echo_n "checking fortran 90 modules extension... " >&6; } -if test "${ax_cv_f90_modext+set}" = set; then +if ${ax_cv_f90_modext+:} false; then : $as_echo_n "(cached) " >&6 else ac_ext=${ac_fc_srcext-f} @@ -7217,7 +6624,7 @@ while test \( -f tmpdir_$i \) -o \( -d tmpdir_$i \) ; do done mkdir tmpdir_$i cd tmpdir_$i -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF module conftest_module contains @@ -7227,24 +6634,7 @@ cat >conftest.$ac_ext <<_ACEOF end module conftest_module _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_fc_try_compile "$LINENO"; then : ax_cv_f90_modext=`ls | sed -n 's,conftest_module\.,,p'` if test x$ax_cv_f90_modext = x ; then ax_cv_f90_modext=`ls | sed -n 's,CONFTEST_MODULE\.,,p'` @@ -7254,12 +6644,8 @@ $as_echo "$ac_try_echo") >&5 fi else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ax_cv_f90_modext=unknown + ax_cv_f90_modext=unknown fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext cd .. rm -fr tmpdir_$i @@ -7271,12 +6657,12 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu fi -{ $as_echo "$as_me:$LINENO: result: $ax_cv_f90_modext" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ax_cv_f90_modext" >&5 $as_echo "$ax_cv_f90_modext" >&6; } -{ $as_echo "$as_me:$LINENO: checking fortran 90 modules inclusion flag" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking fortran 90 modules inclusion flag" >&5 $as_echo_n "checking fortran 90 modules inclusion flag... " >&6; } -if test "${ax_cv_f90_modflag+set}" = set; then +if ${ax_cv_f90_modflag+:} false; then : $as_echo_n "(cached) " >&6 else ac_ext=${ac_fc_srcext-f} @@ -7291,7 +6677,7 @@ done mkdir tmpdir_$i cd tmpdir_$i ac_ext='f90'; -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF module conftest_module contains @@ -7301,32 +6687,9 @@ cat >conftest.$ac_ext <<_ACEOF end module conftest_module _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - : -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - +if ac_fn_fc_try_compile "$LINENO"; then : fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext cd ..; ax_cv_f90_modflag="not found" @@ -7334,7 +6697,7 @@ for ax_flag in "-I " "-M" "-p"; do if test "$ax_cv_f90_modflag" = "not found" ; then ax_save_FCFLAGS="$FCFLAGS" FCFLAGS="$ax_save_FCFLAGS ${ax_flag}tmpdir_$i" - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program conftest_program use conftest_module @@ -7342,41 +6705,16 @@ for ax_flag in "-I " "-M" "-p"; do end program conftest_program _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then +if ac_fn_fc_try_compile "$LINENO"; then : ax_cv_f90_modflag="$ax_flag" -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext FCFLAGS="$ax_save_FCFLAGS" fi done rm -fr tmpdir_$i if test "$ax_cv_f90_modflag" = "not found" ; then - { { $as_echo "$as_me:$LINENO: error: unable to find compiler flag for modules inclusion" >&5 -$as_echo "$as_me: error: unable to find compiler flag for modules inclusion" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "unable to find compiler flag for modules inclusion" "$LINENO" 5 fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -7386,7 +6724,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu fi -{ $as_echo "$as_me:$LINENO: result: $ax_cv_f90_modflag" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ax_cv_f90_modflag" >&5 $as_echo "$ax_cv_f90_modflag" >&6; } MODEXT=".$ax_cv_f90_modext" FMFLAG="${ax_cv_f90_modflag%% *}" @@ -7408,7 +6746,7 @@ fi if test x"$pac_cv_serial_mpi" == x"yes" ; then FDEFINES="$psblas_cv_define_prepend-DSERIAL_MPI $psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; else - { $as_echo "$as_me:$LINENO: checking MPI Fortran 2008 interface" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking MPI Fortran 2008 interface" >&5 $as_echo_n "checking MPI Fortran 2008 interface... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -7418,46 +6756,25 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program test use mpi_f08 end program test _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } pac_cv_mpi_f08="yes"; : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } pac_cv_mpi_f08="no"; echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -7469,7 +6786,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu if test x"$pac_cv_mpi_f08" == x"yes" ; then FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES"; else - { $as_echo "$as_me:$LINENO: checking for Fortran MPI mod" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran MPI mod" >&5 $as_echo_n "checking for Fortran MPI mod... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -7479,44 +6796,23 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program test use mpi end program test _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } FDEFINES="$psblas_cv_define_prepend-DMPI_MOD $FDEFINES" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 FDEFINES="$psblas_cv_define_prepend-DMPI_H $FDEFINES" fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -7529,31 +6825,69 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu fi -{ $as_echo "$as_me:$LINENO: checking whether we want long (8 bytes) integers" >&5 -$as_echo_n "checking whether we want long (8 bytes) integers... " >&6; } -# Check whether --enable-long-integers was given. -if test "${enable_long_integers+set}" = set; then - enableval=$enable_long_integers; -pac_cv_long_integers="yes"; +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking what size in bytes we want for local indices and data" >&5 +$as_echo_n "checking what size in bytes we want for local indices and data... " >&6; } - -fi - -if test x"$pac_cv_long_integers" == x"yes" ; then - { $as_echo "$as_me:$LINENO: result: yes." >&5 -$as_echo "yes." >&6; } +# Check whether --with-ipk was given. +if test "${with_ipk+set}" = set; then : + withval=$with_ipk; pac_cv_ipk_size=$withval; else - pac_cv_long_integers="no"; - { $as_echo "$as_me:$LINENO: result: no." >&5 -$as_echo "no." >&6; } + pac_cv_ipk_size=4; + +fi + +if test x"$pac_cv_ipk_size" == x"4" || test x"$pac_cv_ipk_size" == x"8" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Size: $pac_cv_ipk_size." >&5 +$as_echo "Size: $pac_cv_ipk_size." >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Unsupported value for IPK: $pac_cv_ipk_size, defaulting to 4." >&5 +$as_echo "Unsupported value for IPK: $pac_cv_ipk_size, defaulting to 4." >&6; } + pac_cv_ipk_size=4; fi -if test x"$pac_cv_long_integers" == x"yes" ; then - FDEFINES="$psblas_cv_define_prepend-DLONG_INTEGERS $FDEFINES"; - CDEFINES="-DLONG_INTEGERS_ $CDEFINES"; + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking what size in bytes we want for global indices and data" >&5 +$as_echo_n "checking what size in bytes we want for global indices and data... " >&6; } + +# Check whether --with-lpk was given. +if test "${with_lpk+set}" = set; then : + withval=$with_lpk; pac_cv_lpk_size=$withval; +else + pac_cv_lpk_size=8; + fi +if test x"$pac_cv_lpk_size" == x"4" || test x"$pac_cv_lpk_size" == x"8"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Size: $pac_cv_lpk_size." >&5 +$as_echo "Size: $pac_cv_lpk_size." >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Unsupported value for LPK: $pac_cv_lpk_size, defaulting to 8." >&5 +$as_echo "Unsupported value for LPK: $pac_cv_lpk_size, defaulting to 8." >&6; } + pac_cv_lpk_size=8; +fi + + +# Defaults for IPK/LPK +if test x"$pac_cv_ipk_size" == x"" ; then + pac_cv_ipk_size=4; +fi +if test x"$pac_cv_lpk_size" == x"" ; then + pac_cv_lpk_size=8; +fi +# Enforce sensible combination +if (( $pac_cv_lpk_size < $pac_cv_ipk_size )); then + { $as_echo "$as_me:${as_lineno-$LINENO}: Invalid combination of size specs IPK ${pac_cv_ipk_size} LPK ${pac_cv_lpk_size}. " >&5 +$as_echo "$as_me: Invalid combination of size specs IPK ${pac_cv_ipk_size} LPK ${pac_cv_lpk_size}. " >&6;}; + { $as_echo "$as_me:${as_lineno-$LINENO}: Forcing equal values" >&5 +$as_echo "$as_me: Forcing equal values" >&6;} + pac_cv_lpk_size=$pac_cv_ipk_size; +fi +FDEFINES="$psblas_cv_define_prepend-DIPK${pac_cv_ipk_size} $FDEFINES"; +FDEFINES="$psblas_cv_define_prepend-DLPK${pac_cv_lpk_size} $FDEFINES"; +CDEFINES="-DIPK${pac_cv_ipk_size} -DLPK${pac_cv_lpk_size} $CDEFINES" + + # # Tests for support of various Fortran features; some of them are critical, # some optional @@ -7562,7 +6896,7 @@ fi # # Critical features # -{ $as_echo "$as_me:$LINENO: checking support for Fortran allocatables TR15581" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran allocatables TR15581" >&5 $as_echo_n "checking support for Fortran allocatables TR15581... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -7572,7 +6906,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF module conftest type outer @@ -7624,43 +6958,19 @@ program testtr15581 end program testtr15581 _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for TR15581. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for TR15581. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for TR15581. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -7673,7 +6983,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_exeext='' ac_ext='f90' ac_link='${MPIFC-$FC} -o conftest${ac_exeext} $FCFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -{ $as_echo "$as_me:$LINENO: checking support for Fortran EXTENDS" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran EXTENDS" >&5 $as_echo_n "checking support for Fortran EXTENDS... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -7683,7 +6993,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program conftest type foo @@ -7695,43 +7005,19 @@ program conftest type(bar) :: barvar end program conftest _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for EXTENDS. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for EXTENDS. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for EXTENDS. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -7741,7 +7027,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran CLASS TBP" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran CLASS TBP" >&5 $as_echo_n "checking support for Fortran CLASS TBP... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -7751,7 +7037,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF module conftest_mod type foo @@ -7782,43 +7068,19 @@ program conftest type(foo) :: foovar end program conftest _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for CLASS and type bound procedures. - Please get a Fortran compiler that supports them, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for CLASS and type bound procedures. - Please get a Fortran compiler that supports them, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for CLASS and type bound procedures. + Please get a Fortran compiler that supports them, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -7828,7 +7090,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran SOURCE= allocation" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran SOURCE= allocation" >&5 $as_echo_n "checking support for Fortran SOURCE= allocation... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -7838,7 +7100,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='f90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program xtt type foo @@ -7855,43 +7117,19 @@ program xtt end program xtt _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for SOURCE= allocation. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for SOURCE= allocation. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for SOURCE= allocation. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -7901,7 +7139,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran MOVE_ALLOC intrinsic" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran MOVE_ALLOC intrinsic" >&5 $as_echo_n "checking support for Fortran MOVE_ALLOC intrinsic... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -7909,7 +7147,7 @@ ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_ext='f90'; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program test_move_alloc integer, allocatable :: a(:), b(:) allocate(a(3)) @@ -7918,43 +7156,19 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu print *, b end program test_move_alloc _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for MOVE_ALLOC. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for MOVE_ALLOC. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for MOVE_ALLOC. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -7964,7 +7178,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran ISO_C_BINDING module" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran ISO_C_BINDING module" >&5 $as_echo_n "checking support for Fortran ISO_C_BINDING module... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -7974,49 +7188,25 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='f90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program conftest use iso_c_binding end program conftest _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for ISO_C_BINDING. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for ISO_C_BINDING. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for ISO_C_BINDING. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8026,7 +7216,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran SAME_TYPE_AS" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran SAME_TYPE_AS" >&5 $as_echo_n "checking support for Fortran SAME_TYPE_AS... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -8036,7 +7226,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='f90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program stt type foo @@ -8053,43 +7243,19 @@ program stt write(*,*) 'nfv2 == nfv1? ', same_type_as(nfv2,nfv1) end program stt _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for SAME_TYPE_AS. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for SAME_TYPE_AS. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for SAME_TYPE_AS. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8099,7 +7265,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran EXTENDS_TYPE_OF" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran EXTENDS_TYPE_OF" >&5 $as_echo_n "checking support for Fortran EXTENDS_TYPE_OF... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -8109,7 +7275,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='f90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program xtt type foo @@ -8124,43 +7290,19 @@ program xtt write(*,*) 'nfv1 extends foov? ', extends_type_of(nfv1,foov) end program xtt _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for EXTENDS_TYPE_OF. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for EXTENDS_TYPE_OF. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for EXTENDS_TYPE_OF. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8170,7 +7312,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran MOLD= allocation" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran MOLD= allocation" >&5 $as_echo_n "checking support for Fortran MOLD= allocation... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -8180,7 +7322,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='f90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program xtt type foo @@ -8197,43 +7339,19 @@ program xtt end program xtt _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 - { { $as_echo "$as_me:$LINENO: error: Sorry, cannot build PSBLAS without support for MOLD= allocation. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&5 -$as_echo "$as_me: error: Sorry, cannot build PSBLAS without support for MOLD= allocation. - Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Sorry, cannot build PSBLAS without support for MOLD= allocation. + Please get a Fortran compiler that supports it, e.g. GNU Fortran 4.8." "$LINENO" 5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8247,7 +7365,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu # Optional features # -{ $as_echo "$as_me:$LINENO: checking support for Fortran VOLATILE" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran VOLATILE" >&5 $as_echo_n "checking support for Fortran VOLATILE... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -8257,44 +7375,23 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program conftest integer, volatile :: i, j end program conftest _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } FDEFINES="$psblas_cv_define_prepend-DHAVE_VOLATILE $FDEFINES" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8304,7 +7401,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking test GENERIC interfaces" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking test GENERIC interfaces" >&5 $as_echo_n "checking test GENERIC interfaces... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -8314,7 +7411,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='F90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF module conftest @@ -8330,39 +7427,18 @@ module conftest end module conftest _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } : else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 FDEFINES="$psblas_cv_define_prepend-DHAVE_BUGGY_GENERICS $FDEFINES" fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8372,7 +7448,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran FLUSH statement" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran FLUSH statement" >&5 $as_echo_n "checking support for Fortran FLUSH statement... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -8382,7 +7458,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='f90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program conftest integer :: iunit=10 @@ -8392,38 +7468,17 @@ program conftest close(10) end program conftest _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } FDEFINES="$psblas_cv_define_prepend-DHAVE_FLUSH_STMT $FDEFINES" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8433,7 +7488,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for ISO_FORTRAN_ENV" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for ISO_FORTRAN_ENV" >&5 $as_echo_n "checking support for ISO_FORTRAN_ENV... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -8443,44 +7498,23 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='f90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program test use iso_fortran_env end program test _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } FDEFINES="$psblas_cv_define_prepend-DHAVE_ISO_FORTRAN_ENV $FDEFINES" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8490,7 +7524,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -{ $as_echo "$as_me:$LINENO: checking support for Fortran FINAL" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking support for Fortran FINAL" >&5 $as_echo_n "checking support for Fortran FINAL... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -8500,7 +7534,7 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu ac_exeext='' ac_ext='f90' ac_fc=${MPIFC-$FC}; - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF module conftest_mod type foo @@ -8521,38 +7555,17 @@ program conftest type(foo) :: foovar end program conftest _ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 +if ac_fn_fc_try_compile "$LINENO"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } FDEFINES="$psblas_cv_define_prepend-DHAVE_FINAL $FDEFINES" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 fi - rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_ext=c ac_cpp='$CPP $CPPFLAGS' @@ -8616,7 +7629,7 @@ pac_blas_ok=no # Check whether --with-blas was given. -if test "${with_blas+set}" = set; then +if test "${with_blas+set}" = set; then : withval=$with_blas; fi @@ -8628,7 +7641,7 @@ case $with_blas in esac # Check whether --with-blasdir was given. -if test "${with_blasdir+set}" = set; then +if test "${with_blasdir+set}" = set; then : withval=$with_blasdir; fi @@ -8654,46 +7667,21 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu if test $pac_blas_ok = no; then if test "x$BLAS_LIBS" != x; then save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $BLAS_LIBDIR $LIBS" - { $as_echo "$as_me:$LINENO: checking for sgemm in $BLAS_LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in $BLAS_LIBS" >&5 $as_echo_n "checking for sgemm in $BLAS_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : pac_blas_ok=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - BLAS_LIBS="" + BLAS_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_blas_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_blas_ok" >&5 $as_echo "$pac_blas_ok" >&6; } LIBS="$save_LIBS" fi @@ -8708,18 +7696,14 @@ ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for ATL_xerbla in -latlas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ATL_xerbla in -latlas" >&5 $as_echo_n "checking for ATL_xerbla in -latlas... " >&6; } -if test "${ac_cv_lib_atlas_ATL_xerbla+set}" = set; then +if ${ac_cv_lib_atlas_ATL_xerbla+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-latlas $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -8737,115 +7721,61 @@ return ATL_xerbla (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_atlas_ATL_xerbla=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_atlas_ATL_xerbla=no + ac_cv_lib_atlas_ATL_xerbla=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_atlas_ATL_xerbla" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_atlas_ATL_xerbla" >&5 $as_echo "$ac_cv_lib_atlas_ATL_xerbla" >&6; } -if test "x$ac_cv_lib_atlas_ATL_xerbla" = x""yes; then +if test "x$ac_cv_lib_atlas_ATL_xerbla" = xyes; then : ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_fc_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for sgemm in -lf77blas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lf77blas" >&5 $as_echo_n "checking for sgemm in -lf77blas... " >&6; } -if test "${ac_cv_lib_f77blas_sgemm+set}" = set; then +if ${ac_cv_lib_f77blas_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lf77blas -latlas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_f77blas_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_f77blas_sgemm=no + ac_cv_lib_f77blas_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_f77blas_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_f77blas_sgemm" >&5 $as_echo "$ac_cv_lib_f77blas_sgemm" >&6; } -if test "x$ac_cv_lib_f77blas_sgemm" = x""yes; then +if test "x$ac_cv_lib_f77blas_sgemm" = xyes; then : ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for cblas_dgemm in -lcblas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cblas_dgemm in -lcblas" >&5 $as_echo_n "checking for cblas_dgemm in -lcblas... " >&6; } -if test "${ac_cv_lib_cblas_cblas_dgemm+set}" = set; then +if ${ac_cv_lib_cblas_cblas_dgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lcblas -lf77blas -latlas $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -8863,43 +7793,18 @@ return cblas_dgemm (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_cblas_cblas_dgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_cblas_cblas_dgemm=no + ac_cv_lib_cblas_cblas_dgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_cblas_cblas_dgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_cblas_cblas_dgemm" >&5 $as_echo "$ac_cv_lib_cblas_cblas_dgemm" >&6; } -if test "x$ac_cv_lib_cblas_cblas_dgemm" = x""yes; then +if test "x$ac_cv_lib_cblas_cblas_dgemm" = xyes; then : pac_blas_ok=yes BLAS_LIBS="-lcblas -lf77blas -latlas $BLAS_LIBDIR" fi @@ -8917,18 +7822,14 @@ ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for ATL_xerbla in -lsatlas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ATL_xerbla in -lsatlas" >&5 $as_echo_n "checking for ATL_xerbla in -lsatlas... " >&6; } -if test "${ac_cv_lib_satlas_ATL_xerbla+set}" = set; then +if ${ac_cv_lib_satlas_ATL_xerbla+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsatlas $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -8946,115 +7847,61 @@ return ATL_xerbla (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_satlas_ATL_xerbla=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_satlas_ATL_xerbla=no + ac_cv_lib_satlas_ATL_xerbla=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_satlas_ATL_xerbla" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_satlas_ATL_xerbla" >&5 $as_echo "$ac_cv_lib_satlas_ATL_xerbla" >&6; } -if test "x$ac_cv_lib_satlas_ATL_xerbla" = x""yes; then +if test "x$ac_cv_lib_satlas_ATL_xerbla" = xyes; then : ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_fc_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for sgemm in -lsatlas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lsatlas" >&5 $as_echo_n "checking for sgemm in -lsatlas... " >&6; } -if test "${ac_cv_lib_satlas_sgemm+set}" = set; then +if ${ac_cv_lib_satlas_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsatlas -lsatlas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_satlas_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_satlas_sgemm=no + ac_cv_lib_satlas_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_satlas_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_satlas_sgemm" >&5 $as_echo "$ac_cv_lib_satlas_sgemm" >&6; } -if test "x$ac_cv_lib_satlas_sgemm" = x""yes; then +if test "x$ac_cv_lib_satlas_sgemm" = xyes; then : ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for cblas_dgemm in -lsatlas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cblas_dgemm in -lsatlas" >&5 $as_echo_n "checking for cblas_dgemm in -lsatlas... " >&6; } -if test "${ac_cv_lib_satlas_cblas_dgemm+set}" = set; then +if ${ac_cv_lib_satlas_cblas_dgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsatlas -lsatlas $LIBS" -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF +cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -9072,43 +7919,18 @@ return cblas_dgemm (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_satlas_cblas_dgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_satlas_cblas_dgemm=no + ac_cv_lib_satlas_cblas_dgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_satlas_cblas_dgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_satlas_cblas_dgemm" >&5 $as_echo "$ac_cv_lib_satlas_cblas_dgemm" >&6; } -if test "x$ac_cv_lib_satlas_cblas_dgemm" = x""yes; then +if test "x$ac_cv_lib_satlas_cblas_dgemm" = xyes; then : pac_blas_ok=yes BLAS_LIBS="-lsatlas $BLAS_LIBDIR" fi @@ -9127,153 +7949,78 @@ ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_fc_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for sgemm in -lblas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lblas" >&5 $as_echo_n "checking for sgemm in -lblas... " >&6; } -if test "${ac_cv_lib_blas_sgemm+set}" = set; then +if ${ac_cv_lib_blas_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lblas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_blas_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_blas_sgemm=no + ac_cv_lib_blas_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_blas_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm" >&5 $as_echo "$ac_cv_lib_blas_sgemm" >&6; } -if test "x$ac_cv_lib_blas_sgemm" = x""yes; then - { $as_echo "$as_me:$LINENO: checking for dgemm in -ldgemm" >&5 +if test "x$ac_cv_lib_blas_sgemm" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dgemm in -ldgemm" >&5 $as_echo_n "checking for dgemm in -ldgemm... " >&6; } -if test "${ac_cv_lib_dgemm_dgemm+set}" = set; then +if ${ac_cv_lib_dgemm_dgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldgemm -lblas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call dgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_dgemm_dgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_dgemm_dgemm=no + ac_cv_lib_dgemm_dgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dgemm_dgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dgemm_dgemm" >&5 $as_echo "$ac_cv_lib_dgemm_dgemm" >&6; } -if test "x$ac_cv_lib_dgemm_dgemm" = x""yes; then - { $as_echo "$as_me:$LINENO: checking for sgemm in -lsgemm" >&5 +if test "x$ac_cv_lib_dgemm_dgemm" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lsgemm" >&5 $as_echo_n "checking for sgemm in -lsgemm... " >&6; } -if test "${ac_cv_lib_sgemm_sgemm+set}" = set; then +if ${ac_cv_lib_sgemm_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsgemm -lblas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_sgemm_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_sgemm_sgemm=no + ac_cv_lib_sgemm_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_sgemm_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sgemm_sgemm" >&5 $as_echo "$ac_cv_lib_sgemm_sgemm" >&6; } -if test "x$ac_cv_lib_sgemm_sgemm" = x""yes; then +if test "x$ac_cv_lib_sgemm_sgemm" = xyes; then : pac_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas $BLAS_LIBDIR" fi @@ -9291,55 +8038,30 @@ ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_fc_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for sgemm in -lopenblas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lopenblas" >&5 $as_echo_n "checking for sgemm in -lopenblas... " >&6; } -if test "${ac_cv_lib_openblas_sgemm+set}" = set; then +if ${ac_cv_lib_openblas_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lopenblas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_openblas_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_openblas_sgemm=no + ac_cv_lib_openblas_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_openblas_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_openblas_sgemm" >&5 $as_echo "$ac_cv_lib_openblas_sgemm" >&6; } -if test "x$ac_cv_lib_openblas_sgemm" = x""yes; then +if test "x$ac_cv_lib_openblas_sgemm" = xyes; then : pac_blas_ok=yes;BLAS_LIBS="-lopenblas $BLAS_LIBDIR" fi @@ -9352,118 +8074,62 @@ if test $pac_blas_ok = no; then # 64 bit if test $host_cpu = x86_64; then as_ac_Lib=`$as_echo "ac_cv_lib_mkl_gf_lp64_$sgemm" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $sgemm in -lmkl_gf_lp64" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $sgemm in -lmkl_gf_lp64" >&5 $as_echo_n "checking for $sgemm in -lmkl_gf_lp64... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${$as_ac_Lib+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmkl_gf_lp64 -lmkl_gf_lp64 -lmkl_sequential -lmkl_core -lpthread $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call $sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" + eval "$as_ac_Lib=no" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf_lp64 -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR" fi # 32 bit elif test $host_cpu = i686; then as_ac_Lib=`$as_echo "ac_cv_lib_mkl_gf_$sgemm" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $sgemm in -lmkl_gf" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $sgemm in -lmkl_gf" >&5 $as_echo_n "checking for $sgemm in -lmkl_gf... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${$as_ac_Lib+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmkl_gf -lmkl_gf -lmkl_sequential -lmkl_core -lpthread $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call $sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" + eval "$as_ac_Lib=no" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : pac_blas_ok=yes;BLAS_LIBS="-lmkl_gf -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR" fi @@ -9473,118 +8139,62 @@ fi # 64-bit if test $host_cpu = x86_64; then as_ac_Lib=`$as_echo "ac_cv_lib_mkl_intel_lp64_$sgemm" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $sgemm in -lmkl_intel_lp64" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $sgemm in -lmkl_intel_lp64" >&5 $as_echo_n "checking for $sgemm in -lmkl_intel_lp64... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${$as_ac_Lib+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmkl_intel_lp64 -lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call $sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" + eval "$as_ac_Lib=no" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel_lp64 -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR" fi # 32-bit elif test $host_cpu = i686; then as_ac_Lib=`$as_echo "ac_cv_lib_mkl_intel_$sgemm" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $sgemm in -lmkl_intel" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $sgemm in -lmkl_intel" >&5 $as_echo_n "checking for $sgemm in -lmkl_intel... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${$as_ac_Lib+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmkl_intel -lmkl_intel -lmkl_sequential -lmkl_core -lpthread $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call $sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" + eval "$as_ac_Lib=no" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : pac_blas_ok=yes;BLAS_LIBS="-lmkl_intel -lmkl_sequential -lmkl_core -lpthread $BLAS_LIBDIR" fi @@ -9594,59 +8204,31 @@ fi # Old versions of MKL if test $pac_blas_ok = no; then as_ac_Lib=`$as_echo "ac_cv_lib_mkl_$sgemm" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $sgemm in -lmkl" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $sgemm in -lmkl" >&5 $as_echo_n "checking for $sgemm in -lmkl... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${$as_ac_Lib+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lmkl -lguide -lpthread $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call $sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" + eval "$as_ac_Lib=no" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : pac_blas_ok=yes;BLAS_LIBS="-lmkl -lguide -lpthread $BLAS_LIBDIR" fi @@ -9655,100 +8237,48 @@ fi # BLAS in Apple vecLib library? if test $pac_blas_ok = no; then save_LIBS="$LIBS"; LIBS="-framework vecLib $LIBS" - { $as_echo "$as_me:$LINENO: checking for $sgemm in -framework vecLib" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $sgemm in -framework vecLib" >&5 $as_echo_n "checking for $sgemm in -framework vecLib... " >&6; } - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main call $sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : pac_blas_ok=yes;BLAS_LIBS="-framework vecLib $BLAS_LIBDIR" -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_blas_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_blas_ok" >&5 $as_echo "$pac_blas_ok" >&6; } LIBS="$save_LIBS" fi # BLAS in Alpha CXML library? if test $pac_blas_ok = no; then - { $as_echo "$as_me:$LINENO: checking for sgemm in -lcxml" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lcxml" >&5 $as_echo_n "checking for sgemm in -lcxml... " >&6; } -if test "${ac_cv_lib_cxml_sgemm+set}" = set; then +if ${ac_cv_lib_cxml_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lcxml $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_cxml_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_cxml_sgemm=no + ac_cv_lib_cxml_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_cxml_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_cxml_sgemm" >&5 $as_echo "$ac_cv_lib_cxml_sgemm" >&6; } -if test "x$ac_cv_lib_cxml_sgemm" = x""yes; then +if test "x$ac_cv_lib_cxml_sgemm" = xyes; then : pac_blas_ok=yes;BLAS_LIBS="-lcxml $BLAS_LIBDIR" fi @@ -9756,55 +8286,30 @@ fi # BLAS in Alpha DXML library? (now called CXML, see above) if test $pac_blas_ok = no; then - { $as_echo "$as_me:$LINENO: checking for sgemm in -ldxml" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -ldxml" >&5 $as_echo_n "checking for sgemm in -ldxml... " >&6; } -if test "${ac_cv_lib_dxml_sgemm+set}" = set; then +if ${ac_cv_lib_dxml_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-ldxml $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_dxml_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_dxml_sgemm=no + ac_cv_lib_dxml_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_dxml_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dxml_sgemm" >&5 $as_echo "$ac_cv_lib_dxml_sgemm" >&6; } -if test "x$ac_cv_lib_dxml_sgemm" = x""yes; then +if test "x$ac_cv_lib_dxml_sgemm" = xyes; then : pac_blas_ok=yes;BLAS_LIBS="-ldxml $BLAS_LIBDIR" fi @@ -9814,104 +8319,54 @@ fi # BLAS in Sun Performance library? if test $pac_blas_ok = no; then if test "x$GCC" != xyes; then # only works with Sun CC - { $as_echo "$as_me:$LINENO: checking for acosp in -lsunmath" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for acosp in -lsunmath" >&5 $as_echo_n "checking for acosp in -lsunmath... " >&6; } -if test "${ac_cv_lib_sunmath_acosp+set}" = set; then +if ${ac_cv_lib_sunmath_acosp+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsunmath $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call acosp end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_sunmath_acosp=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_sunmath_acosp=no + ac_cv_lib_sunmath_acosp=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_sunmath_acosp" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sunmath_acosp" >&5 $as_echo "$ac_cv_lib_sunmath_acosp" >&6; } -if test "x$ac_cv_lib_sunmath_acosp" = x""yes; then - { $as_echo "$as_me:$LINENO: checking for sgemm in -lsunperf" >&5 +if test "x$ac_cv_lib_sunmath_acosp" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lsunperf" >&5 $as_echo_n "checking for sgemm in -lsunperf... " >&6; } -if test "${ac_cv_lib_sunperf_sgemm+set}" = set; then +if ${ac_cv_lib_sunperf_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lsunperf -lsunmath $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_sunperf_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_sunperf_sgemm=no + ac_cv_lib_sunperf_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_sunperf_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sunperf_sgemm" >&5 $as_echo "$ac_cv_lib_sunperf_sgemm" >&6; } -if test "x$ac_cv_lib_sunperf_sgemm" = x""yes; then +if test "x$ac_cv_lib_sunperf_sgemm" = xyes; then : BLAS_LIBS="-xlic_lib=sunperf -lsunmath $BLAS_LIBDIR" pac_blas_ok=yes fi @@ -9924,55 +8379,30 @@ fi # BLAS in SCSL library? (SGI/Cray Scientific Library) if test $pac_blas_ok = no; then - { $as_echo "$as_me:$LINENO: checking for sgemm in -lscs" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lscs" >&5 $as_echo_n "checking for sgemm in -lscs... " >&6; } -if test "${ac_cv_lib_scs_sgemm+set}" = set; then +if ${ac_cv_lib_scs_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lscs $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_scs_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_scs_sgemm=no + ac_cv_lib_scs_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_scs_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_scs_sgemm" >&5 $as_echo "$ac_cv_lib_scs_sgemm" >&6; } -if test "x$ac_cv_lib_scs_sgemm" = x""yes; then +if test "x$ac_cv_lib_scs_sgemm" = xyes; then : pac_blas_ok=yes; BLAS_LIBS="-lscs $BLAS_LIBDIR" fi @@ -9981,59 +8411,31 @@ fi # BLAS in SGIMATH library? if test $pac_blas_ok = no; then as_ac_Lib=`$as_echo "ac_cv_lib_complib.sgimath_$sgemm" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $sgemm in -lcomplib.sgimath" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $sgemm in -lcomplib.sgimath" >&5 $as_echo_n "checking for $sgemm in -lcomplib.sgimath... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${$as_ac_Lib+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lcomplib.sgimath $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call $sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" + eval "$as_ac_Lib=no" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : pac_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath $BLAS_LIBDIR" fi @@ -10042,108 +8444,55 @@ fi # BLAS in IBM ESSL library? (requires generic BLAS lib, too) if test $pac_blas_ok = no; then as_ac_Lib=`$as_echo "ac_cv_lib_blas_$sgemm" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for $sgemm in -lblas" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $sgemm in -lblas" >&5 $as_echo_n "checking for $sgemm in -lblas... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${$as_ac_Lib+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lblas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call $sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" + eval "$as_ac_Lib=no" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then - { $as_echo "$as_me:$LINENO: checking for sgemm in -lessl" >&5 +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lessl" >&5 $as_echo_n "checking for sgemm in -lessl... " >&6; } -if test "${ac_cv_lib_essl_sgemm+set}" = set; then +if ${ac_cv_lib_essl_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lessl -lblas $FLIBS $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_essl_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_essl_sgemm=no + ac_cv_lib_essl_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_essl_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_essl_sgemm" >&5 $as_echo "$ac_cv_lib_essl_sgemm" >&6; } -if test "x$ac_cv_lib_essl_sgemm" = x""yes; then +if test "x$ac_cv_lib_essl_sgemm" = xyes; then : pac_blas_ok=yes; BLAS_LIBS="-lessl -lblas $BLAS_LIBDIR" fi @@ -10157,56 +8506,30 @@ ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_fc_compiler_gnu - -{ $as_echo "$as_me:$LINENO: checking for sgemm in -lblas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lblas" >&5 $as_echo_n "checking for sgemm in -lblas... " >&6; } -if test "${ac_cv_lib_blas_sgemm+set}" = set; then +if ${ac_cv_lib_blas_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lblas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_blas_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_blas_sgemm=no + ac_cv_lib_blas_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_blas_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm" >&5 $as_echo "$ac_cv_lib_blas_sgemm" >&6; } -if test "x$ac_cv_lib_blas_sgemm" = x""yes; then +if test "x$ac_cv_lib_blas_sgemm" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBBLAS 1 _ACEOF @@ -10221,43 +8544,18 @@ fi # BLAS linked to by default? (happens on some supercomputers) if test $pac_blas_ok = no; then - cat >conftest.$ac_ext <<_ACEOF + cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : pac_blas_ok=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - BLAS_LIBS="" + BLAS_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext fi # Generic BLAS library? @@ -10267,55 +8565,30 @@ ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_fc_compiler_gnu - { $as_echo "$as_me:$LINENO: checking for sgemm in -lblas" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lblas" >&5 $as_echo_n "checking for sgemm in -lblas... " >&6; } -if test "${ac_cv_lib_blas_sgemm+set}" = set; then +if ${ac_cv_lib_blas_sgemm+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lblas $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call sgemm end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : ac_cv_lib_blas_sgemm=yes else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_cv_lib_blas_sgemm=no + ac_cv_lib_blas_sgemm=no fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_lib_blas_sgemm" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm" >&5 $as_echo "$ac_cv_lib_blas_sgemm" >&6; } -if test "x$ac_cv_lib_blas_sgemm" = x""yes; then +if test "x$ac_cv_lib_blas_sgemm" = xyes; then : pac_blas_ok=yes; BLAS_LIBS="-lblas $BLAS_LIBDIR" fi @@ -10327,16 +8600,12 @@ LIBS="$pac_blas_save_LIBS" # Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: if test x"$pac_blas_ok" = xyes; then -cat >>confdefs.h <<\_ACEOF -#define HAVE_BLAS 1 -_ACEOF +$as_echo "#define HAVE_BLAS 1" >>confdefs.h : else pac_blas_ok=no - { { $as_echo "$as_me:$LINENO: error: Cannot find BLAS library, specify a path using --with-blas=DIR/LIB (for example --with-blas=/usr/path/lib/libcxml.a)" >&5 -$as_echo "$as_me: error: Cannot find BLAS library, specify a path using --with-blas=DIR/LIB (for example --with-blas=/usr/path/lib/libcxml.a)" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "Cannot find BLAS library, specify a path using --with-blas=DIR/LIB (for example --with-blas=/usr/path/lib/libcxml.a)" "$LINENO" 5 fi @@ -10345,7 +8614,7 @@ pac_lapack_ok=no # Check whether --with-lapack was given. -if test "${with_lapack+set}" = set; then +if test "${with_lapack+set}" = set; then : withval=$with_lapack; fi @@ -10367,7 +8636,7 @@ fi # First, check LAPACK_LIBS environment variable if test "x$LAPACK_LIBS" != x; then save_LIBS="$LIBS"; LIBS="$LAPACK_LIBS $BLAS_LIBS $LIBS $FLIBS" - { $as_echo "$as_me:$LINENO: checking for cheev in $LAPACK_LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cheev in $LAPACK_LIBS" >&5 $as_echo_n "checking for cheev in $LAPACK_LIBS... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -10379,16 +8648,16 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu call cheev end EOF - if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 (eval $ac_link) 2>&5 ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && test -s conftest${ac_exeext}; then + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && test -s conftest${ac_exeext}; then pac_lapack_ok=yes - { $as_echo "$as_me:$LINENO: result: yes" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 @@ -10409,7 +8678,7 @@ fi # LAPACK linked to by default? (is sometimes included in BLAS lib) if test $pac_lapack_ok = no; then save_LIBS="$LIBS"; LIBS="$LIBS $BLAS_LIBS $FLIBS" - { $as_echo "$as_me:$LINENO: checking for cheev in default libs" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cheev in default libs" >&5 $as_echo_n "checking for cheev in default libs... " >&6; } ac_ext=${ac_fc_srcext-f} ac_compile='$FC -c $FCFLAGS $ac_fcflags_srcext conftest.$ac_ext >&5' @@ -10421,16 +8690,16 @@ ac_compiler_gnu=$ac_cv_fc_compiler_gnu call cheev end EOF - if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_link\""; } >&5 (eval $ac_link) 2>&5 ac_status=$? - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && test -s conftest${ac_exeext}; then + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && test -s conftest${ac_exeext}; then pac_lapack_ok=yes - { $as_echo "$as_me:$LINENO: result: yes" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } echo "configure: failed program was:" >&5 cat conftest.$ac_ext >&5 @@ -10455,59 +8724,31 @@ ac_link='$FC -o conftest$ac_exeext $FCFLAGS $LDFLAGS $ac_fcflags_srcext conftest ac_compiler_gnu=$ac_cv_fc_compiler_gnu as_ac_Lib=`$as_echo "ac_cv_lib_$lapack''_cheev" | $as_tr_sh` -{ $as_echo "$as_me:$LINENO: checking for cheev in -l$lapack" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for cheev in -l$lapack" >&5 $as_echo_n "checking for cheev in -l$lapack... " >&6; } -if { as_var=$as_ac_Lib; eval "test \"\${$as_var+set}\" = set"; }; then +if eval \${$as_ac_Lib+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-l$lapack $FLIBS $LIBS" -cat >conftest.$ac_ext <<_ACEOF +cat > conftest.$ac_ext <<_ACEOF program main call cheev end _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_fc_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_fc_try_link "$LINENO"; then : eval "$as_ac_Lib=yes" else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - eval "$as_ac_Lib=no" + eval "$as_ac_Lib=no" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -ac_res=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } -as_val=`eval 'as_val=${'$as_ac_Lib'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : pac_lapack_ok=yes; LAPACK_LIBS="-l$lapack" fi @@ -10555,16 +8796,16 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu #fi -{ $as_echo "$as_me:$LINENO: checking for gnumake" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gnumake" >&5 $as_echo_n "checking for gnumake... " >&6; } MAKE=${MAKE:-make} if $MAKE --version 2>&1 | grep -e"GNU Make" >/dev/null; then - { $as_echo "$as_me:$LINENO: result: yes" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } psblas_make_gnumake='yes' else - { $as_echo "$as_me:$LINENO: result: no" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } psblas_make_gnumake='no' fi @@ -10584,7 +8825,7 @@ fi # Check whether --with-rsb was given. -if test "${with_rsb+set}" = set; then +if test "${with_rsb+set}" = set; then : withval=$with_rsb; if test x"$withval" = xno; then want_rsb_libs= ; else if test x"$withval" = xyes ; then want_rsb_libs=yes ; else want_rsb_libs="$withval" ; fi ; fi else @@ -10609,7 +8850,7 @@ LIBS="$RSB_LIBS ${LIBS}" # Check whether --with-metis was given. -if test "${with_metis+set}" = set; then +if test "${with_metis+set}" = set; then : withval=$with_metis; psblas_cv_metis=$withval else psblas_cv_metis='-lmetis' @@ -10617,7 +8858,7 @@ fi # Check whether --with-metisdir was given. -if test "${with_metisdir+set}" = set; then +if test "${with_metisdir+set}" = set; then : withval=$with_metisdir; psblas_cv_metisdir=$withval else psblas_cv_metisdir='' @@ -10625,7 +8866,7 @@ fi # Check whether --with-metisincdir was given. -if test "${with_metisincdir+set}" = set; then +if test "${with_metisincdir+set}" = set; then : withval=$with_metisincdir; psblas_cv_metisincdir=$withval else psblas_cv_metisincdir='' @@ -10633,7 +8874,7 @@ fi # Check whether --with-metislibdir was given. -if test "${with_metislibdir+set}" = set; then +if test "${with_metislibdir+set}" = set; then : withval=$with_metislibdir; psblas_cv_metislibdir=$withval else psblas_cv_metislibdir='' @@ -10663,152 +8904,13 @@ if test "x$psblas_cv_metislibdir" != "x"; then METIS_LIBDIR="-L$psblas_cv_metislibdir" fi -{ $as_echo "$as_me:$LINENO: metis dir $psblas_cv_metisdir" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: metis dir $psblas_cv_metisdir" >&5 $as_echo "$as_me: metis dir $psblas_cv_metisdir" >&6;} - - for ac_header in limits.h metis.h -do -as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 -$as_echo_n "checking for $ac_header... " >&6; } -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -fi -ac_res=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -else - # Is the header compilable? -{ $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 -$as_echo_n "checking $ac_header usability... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -#include <$ac_header> -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_header_compiler=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_compiler=no -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 -$as_echo "$ac_header_compiler" >&6; } - -# Is the header present? -{ $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 -$as_echo_n "checking $ac_header presence... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include <$ac_header> -_ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then - ac_header_preproc=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_preproc=no -fi - -rm -f conftest.err conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 -$as_echo "$ac_header_preproc" >&6; } - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in - yes:no: ) - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 -$as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} - ac_header_preproc=yes - ;; - no:yes:* ) - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 -$as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -$as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 -$as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 -$as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -$as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 -$as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} - ( cat <<\_ASBOX -## ----------------------------------------------------------- ## -## Report this to https://github.com/sfilippone/psblas3/issues ## -## ----------------------------------------------------------- ## -_ASBOX - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac -{ $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 -$as_echo_n "checking for $ac_header... " >&6; } -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -else - eval "$as_ac_Header=\$ac_header_preproc" -fi -ac_res=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - -fi -as_val=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF @@ -10824,152 +8926,13 @@ if test "x$pac_metis_header_ok" == "xno" ; then METIS_INCLUDES="-I$psblas_cv_metisdir/include -I$psblas_cv_metisdir/Include " CPPFLAGS="$METIS_INCLUDES $SAVE_CPPFLAGS" - { $as_echo "$as_me:$LINENO: checking for metis_h in $METIS_INCLUDES" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for metis_h in $METIS_INCLUDES" >&5 $as_echo_n "checking for metis_h in $METIS_INCLUDES... " >&6; } - - -for ac_header in limits.h metis.h -do -as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 -$as_echo_n "checking for $ac_header... " >&6; } -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -fi -ac_res=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -else - # Is the header compilable? -{ $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 -$as_echo_n "checking $ac_header usability... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -#include <$ac_header> -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_header_compiler=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_compiler=no -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 -$as_echo "$ac_header_compiler" >&6; } - -# Is the header present? -{ $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 -$as_echo_n "checking $ac_header presence... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include <$ac_header> -_ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then - ac_header_preproc=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_preproc=no -fi - -rm -f conftest.err conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 -$as_echo "$ac_header_preproc" >&6; } - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in - yes:no: ) - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 -$as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} - ac_header_preproc=yes - ;; - no:yes:* ) - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 -$as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -$as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 -$as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 -$as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -$as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 -$as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} - ( cat <<\_ASBOX -## ----------------------------------------------------------- ## -## Report this to https://github.com/sfilippone/psblas3/issues ## -## ----------------------------------------------------------- ## -_ASBOX - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac -{ $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 -$as_echo_n "checking for $ac_header... " >&6; } -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -else - eval "$as_ac_Header=\$ac_header_preproc" -fi -ac_res=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - -fi -as_val=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then + for ac_header in limits.h metis.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF @@ -10985,150 +8948,11 @@ if test "x$pac_metis_header_ok" == "xno" ; then unset ac_cv_header_metis_h METIS_INCLUDES="-I$psblas_cv_metisdir/UFconfig -I$psblas_cv_metisdir/METIS/Include -I$psblas_cv_metisdir/METIS/Include" CPPFLAGS="$METIS_INCLUDES $SAVE_CPPFLAGS" - - -for ac_header in limits.h metis.h -do -as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - { $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 -$as_echo_n "checking for $ac_header... " >&6; } -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -fi -ac_res=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } -else - # Is the header compilable? -{ $as_echo "$as_me:$LINENO: checking $ac_header usability" >&5 -$as_echo_n "checking $ac_header usability... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -#include <$ac_header> -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_header_compiler=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_compiler=no -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 -$as_echo "$ac_header_compiler" >&6; } - -# Is the header present? -{ $as_echo "$as_me:$LINENO: checking $ac_header presence" >&5 -$as_echo_n "checking $ac_header presence... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include <$ac_header> -_ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then - ac_header_preproc=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_preproc=no -fi - -rm -f conftest.err conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 -$as_echo "$ac_header_preproc" >&6; } - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in - yes:no: ) - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 -$as_echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} - ac_header_preproc=yes - ;; - no:yes:* ) - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 -$as_echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 -$as_echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 -$as_echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 -$as_echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 -$as_echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 -$as_echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} - ( cat <<\_ASBOX -## ----------------------------------------------------------- ## -## Report this to https://github.com/sfilippone/psblas3/issues ## -## ----------------------------------------------------------- ## -_ASBOX - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac -{ $as_echo "$as_me:$LINENO: checking for $ac_header" >&5 -$as_echo_n "checking for $ac_header... " >&6; } -if { as_var=$as_ac_Header; eval "test \"\${$as_var+set}\" = set"; }; then - $as_echo_n "(cached) " >&6 -else - eval "$as_ac_Header=\$ac_header_preproc" -fi -ac_res=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - { $as_echo "$as_me:$LINENO: result: $ac_res" >&5 -$as_echo "$ac_res" >&6; } - -fi -as_val=`eval 'as_val=${'$as_ac_Header'} - $as_echo "$as_val"'` - if test "x$as_val" = x""yes; then + for ac_header in limits.h metis.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF @@ -11146,13 +8970,9 @@ if test "x$pac_metis_header_ok" == "xyes" ; then psblas_cv_metis_includes="$METIS_INCLUDES" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $LIBS"; - { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 $as_echo_n "checking for METIS_PartGraphKway in $METIS_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -11170,52 +8990,23 @@ return METIS_PartGraphKway (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS="" + psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_metis_lib_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_metis_lib_ok" >&5 $as_echo "$pac_metis_lib_ok" >&6; } if test "x$pac_metis_lib_ok" == "xno" ; then METIS_LIBDIR="-L$psblas_cv_metisdir/Lib -L$psblas_cv_metisdir/lib" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" - { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 $as_echo_n "checking for METIS_PartGraphKway in $METIS_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -11233,52 +9024,23 @@ return METIS_PartGraphKway (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS="" + psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_metis_lib_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_metis_lib_ok" >&5 $as_echo "$pac_metis_lib_ok" >&6; } fi if test "x$pac_metis_lib_ok" == "xno" ; then METIS_LIBDIR="-L$psblas_cv_metisdir/METIS/Lib -L$psblas_cv_metisdir/METIS/Lib" METIS_LIBS="$psblas_cv_metis $METIS_LIBDIR" LIBS="$METIS_LIBS -lm $SAVE_LIBS" - { $as_echo "$as_me:$LINENO: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for METIS_PartGraphKway in $METIS_LIBS" >&5 $as_echo_n "checking for METIS_PartGraphKway in $METIS_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -11296,50 +9058,21 @@ return METIS_PartGraphKway (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS="" + psblas_cv_have_metis=no;pac_metis_lib_ok=no; METIS_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_metis_lib_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_metis_lib_ok" >&5 $as_echo "$pac_metis_lib_ok" >&6; } fi fi if test "x$pac_metis_lib_ok" == "xyes" ; then - { $as_echo "$as_me:$LINENO: checking for METIS_SetDefaultOptions in $LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for METIS_SetDefaultOptions in $LIBS" >&5 $as_echo_n "checking for METIS_SetDefaultOptions in $LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -11357,39 +9090,14 @@ return METIS_SetDefaultOptions (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : psblas_cv_have_metis=yes;pac_metis_lib_ok=yes; else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_have_metis=no;pac_metis_lib_ok="no. Unusable METIS version, sorry."; METIS_LIBS="" + psblas_cv_have_metis=no;pac_metis_lib_ok="no. Unusable METIS version, sorry."; METIS_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_metis_lib_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_metis_lib_ok" >&5 $as_echo "$pac_metis_lib_ok" >&6; } fi @@ -11403,7 +9111,7 @@ fi # Check whether --with-amd was given. -if test "${with_amd+set}" = set; then +if test "${with_amd+set}" = set; then : withval=$with_amd; psblas_cv_amd=$withval else psblas_cv_amd='-lamd' @@ -11411,7 +9119,7 @@ fi # Check whether --with-amddir was given. -if test "${with_amddir+set}" = set; then +if test "${with_amddir+set}" = set; then : withval=$with_amddir; psblas_cv_amddir=$withval else psblas_cv_amddir='' @@ -11419,7 +9127,7 @@ fi # Check whether --with-amdincdir was given. -if test "${with_amdincdir+set}" = set; then +if test "${with_amdincdir+set}" = set; then : withval=$with_amdincdir; psblas_cv_amdincdir=$withval else psblas_cv_amdincdir='' @@ -11427,7 +9135,7 @@ fi # Check whether --with-amdlibdir was given. -if test "${with_amdlibdir+set}" = set; then +if test "${with_amdlibdir+set}" = set; then : withval=$with_amdlibdir; psblas_cv_amdlibdir=$withval else psblas_cv_amdlibdir='' @@ -11457,141 +9165,10 @@ if test "x$psblas_cv_amdlibdir" != "x"; then AMD_LIBDIR="-L$psblas_cv_amdlibdir" fi -{ $as_echo "$as_me:$LINENO: amd dir $psblas_cv_amddir" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: amd dir $psblas_cv_amddir" >&5 $as_echo "$as_me: amd dir $psblas_cv_amddir" >&6;} -if test "${ac_cv_header_amd_h+set}" = set; then - { $as_echo "$as_me:$LINENO: checking for amd.h" >&5 -$as_echo_n "checking for amd.h... " >&6; } -if test "${ac_cv_header_amd_h+set}" = set; then - $as_echo_n "(cached) " >&6 -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_amd_h" >&5 -$as_echo "$ac_cv_header_amd_h" >&6; } -else - # Is the header compilable? -{ $as_echo "$as_me:$LINENO: checking amd.h usability" >&5 -$as_echo_n "checking amd.h usability... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -#include -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_header_compiler=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_compiler=no -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 -$as_echo "$ac_header_compiler" >&6; } - -# Is the header present? -{ $as_echo "$as_me:$LINENO: checking amd.h presence" >&5 -$as_echo_n "checking amd.h presence... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -_ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then - ac_header_preproc=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_preproc=no -fi - -rm -f conftest.err conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 -$as_echo "$ac_header_preproc" >&6; } - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in - yes:no: ) - { $as_echo "$as_me:$LINENO: WARNING: amd.h: accepted by the compiler, rejected by the preprocessor!" >&5 -$as_echo "$as_me: WARNING: amd.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: amd.h: proceeding with the compiler's result" >&2;} - ac_header_preproc=yes - ;; - no:yes:* ) - { $as_echo "$as_me:$LINENO: WARNING: amd.h: present but cannot be compiled" >&5 -$as_echo "$as_me: WARNING: amd.h: present but cannot be compiled" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: check for missing prerequisite headers?" >&5 -$as_echo "$as_me: WARNING: amd.h: check for missing prerequisite headers?" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: see the Autoconf documentation" >&5 -$as_echo "$as_me: WARNING: amd.h: see the Autoconf documentation" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: section \"Present But Cannot Be Compiled\"" >&5 -$as_echo "$as_me: WARNING: amd.h: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: proceeding with the preprocessor's result" >&5 -$as_echo "$as_me: WARNING: amd.h: proceeding with the preprocessor's result" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: in the future, the compiler will take precedence" >&5 -$as_echo "$as_me: WARNING: amd.h: in the future, the compiler will take precedence" >&2;} - ( cat <<\_ASBOX -## ----------------------------------------------------------- ## -## Report this to https://github.com/sfilippone/psblas3/issues ## -## ----------------------------------------------------------- ## -_ASBOX - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac -{ $as_echo "$as_me:$LINENO: checking for amd.h" >&5 -$as_echo_n "checking for amd.h... " >&6; } -if test "${ac_cv_header_amd_h+set}" = set; then - $as_echo_n "(cached) " >&6 -else - ac_cv_header_amd_h=$ac_header_preproc -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_amd_h" >&5 -$as_echo "$ac_cv_header_amd_h" >&6; } - -fi -if test "x$ac_cv_header_amd_h" = x""yes; then +ac_fn_c_check_header_mongrel "$LINENO" "amd.h" "ac_cv_header_amd_h" "$ac_includes_default" +if test "x$ac_cv_header_amd_h" = xyes; then : pac_amd_header_ok=yes else pac_amd_header_ok=no; AMD_INCLUDES="" @@ -11603,141 +9180,10 @@ if test "x$pac_amd_header_ok" == "xno" ; then AMD_INCLUDES="-I$psblas_cv_amddir/include -I$psblas_cv_amddir/Include " CPPFLAGS="$AMD_INCLUDES $SAVE_CPPFLAGS" - { $as_echo "$as_me:$LINENO: checking for amd_h in $AMD_INCLUDES" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for amd_h in $AMD_INCLUDES" >&5 $as_echo_n "checking for amd_h in $AMD_INCLUDES... " >&6; } - if test "${ac_cv_header_amd_h+set}" = set; then - { $as_echo "$as_me:$LINENO: checking for amd.h" >&5 -$as_echo_n "checking for amd.h... " >&6; } -if test "${ac_cv_header_amd_h+set}" = set; then - $as_echo_n "(cached) " >&6 -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_amd_h" >&5 -$as_echo "$ac_cv_header_amd_h" >&6; } -else - # Is the header compilable? -{ $as_echo "$as_me:$LINENO: checking amd.h usability" >&5 -$as_echo_n "checking amd.h usability... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -#include -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_header_compiler=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_compiler=no -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 -$as_echo "$ac_header_compiler" >&6; } - -# Is the header present? -{ $as_echo "$as_me:$LINENO: checking amd.h presence" >&5 -$as_echo_n "checking amd.h presence... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -_ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then - ac_header_preproc=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_preproc=no -fi - -rm -f conftest.err conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 -$as_echo "$ac_header_preproc" >&6; } - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in - yes:no: ) - { $as_echo "$as_me:$LINENO: WARNING: amd.h: accepted by the compiler, rejected by the preprocessor!" >&5 -$as_echo "$as_me: WARNING: amd.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: amd.h: proceeding with the compiler's result" >&2;} - ac_header_preproc=yes - ;; - no:yes:* ) - { $as_echo "$as_me:$LINENO: WARNING: amd.h: present but cannot be compiled" >&5 -$as_echo "$as_me: WARNING: amd.h: present but cannot be compiled" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: check for missing prerequisite headers?" >&5 -$as_echo "$as_me: WARNING: amd.h: check for missing prerequisite headers?" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: see the Autoconf documentation" >&5 -$as_echo "$as_me: WARNING: amd.h: see the Autoconf documentation" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: section \"Present But Cannot Be Compiled\"" >&5 -$as_echo "$as_me: WARNING: amd.h: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: proceeding with the preprocessor's result" >&5 -$as_echo "$as_me: WARNING: amd.h: proceeding with the preprocessor's result" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: in the future, the compiler will take precedence" >&5 -$as_echo "$as_me: WARNING: amd.h: in the future, the compiler will take precedence" >&2;} - ( cat <<\_ASBOX -## ----------------------------------------------------------- ## -## Report this to https://github.com/sfilippone/psblas3/issues ## -## ----------------------------------------------------------- ## -_ASBOX - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac -{ $as_echo "$as_me:$LINENO: checking for amd.h" >&5 -$as_echo_n "checking for amd.h... " >&6; } -if test "${ac_cv_header_amd_h+set}" = set; then - $as_echo_n "(cached) " >&6 -else - ac_cv_header_amd_h=$ac_header_preproc -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_amd_h" >&5 -$as_echo "$ac_cv_header_amd_h" >&6; } - -fi -if test "x$ac_cv_header_amd_h" = x""yes; then + ac_fn_c_check_header_mongrel "$LINENO" "amd.h" "ac_cv_header_amd_h" "$ac_includes_default" +if test "x$ac_cv_header_amd_h" = xyes; then : pac_amd_header_ok=yes else pac_amd_header_ok=no; AMD_INCLUDES="" @@ -11749,139 +9195,8 @@ if test "x$pac_amd_header_ok" == "xno" ; then unset ac_cv_header_amd_h AMD_INCLUDES="-I$psblas_cv_amddir/UFconfig -I$psblas_cv_amddir/AMD/Include -I$psblas_cv_amddir/AMD/Include" CPPFLAGS="$AMD_INCLUDES $SAVE_CPPFLAGS" - if test "${ac_cv_header_amd_h+set}" = set; then - { $as_echo "$as_me:$LINENO: checking for amd.h" >&5 -$as_echo_n "checking for amd.h... " >&6; } -if test "${ac_cv_header_amd_h+set}" = set; then - $as_echo_n "(cached) " >&6 -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_amd_h" >&5 -$as_echo "$ac_cv_header_amd_h" >&6; } -else - # Is the header compilable? -{ $as_echo "$as_me:$LINENO: checking amd.h usability" >&5 -$as_echo_n "checking amd.h usability... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -$ac_includes_default -#include -_ACEOF -rm -f conftest.$ac_objext -if { (ac_try="$ac_compile" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_compile") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest.$ac_objext; then - ac_header_compiler=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_compiler=no -fi - -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 -$as_echo "$ac_header_compiler" >&6; } - -# Is the header present? -{ $as_echo "$as_me:$LINENO: checking amd.h presence" >&5 -$as_echo_n "checking amd.h presence... " >&6; } -cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -#include -_ACEOF -if { (ac_try="$ac_cpp conftest.$ac_ext" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_cpp conftest.$ac_ext") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } >/dev/null && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then - ac_header_preproc=yes -else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - ac_header_preproc=no -fi - -rm -f conftest.err conftest.$ac_ext -{ $as_echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 -$as_echo "$ac_header_preproc" >&6; } - -# So? What about this header? -case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in - yes:no: ) - { $as_echo "$as_me:$LINENO: WARNING: amd.h: accepted by the compiler, rejected by the preprocessor!" >&5 -$as_echo "$as_me: WARNING: amd.h: accepted by the compiler, rejected by the preprocessor!" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: proceeding with the compiler's result" >&5 -$as_echo "$as_me: WARNING: amd.h: proceeding with the compiler's result" >&2;} - ac_header_preproc=yes - ;; - no:yes:* ) - { $as_echo "$as_me:$LINENO: WARNING: amd.h: present but cannot be compiled" >&5 -$as_echo "$as_me: WARNING: amd.h: present but cannot be compiled" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: check for missing prerequisite headers?" >&5 -$as_echo "$as_me: WARNING: amd.h: check for missing prerequisite headers?" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: see the Autoconf documentation" >&5 -$as_echo "$as_me: WARNING: amd.h: see the Autoconf documentation" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: section \"Present But Cannot Be Compiled\"" >&5 -$as_echo "$as_me: WARNING: amd.h: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: proceeding with the preprocessor's result" >&5 -$as_echo "$as_me: WARNING: amd.h: proceeding with the preprocessor's result" >&2;} - { $as_echo "$as_me:$LINENO: WARNING: amd.h: in the future, the compiler will take precedence" >&5 -$as_echo "$as_me: WARNING: amd.h: in the future, the compiler will take precedence" >&2;} - ( cat <<\_ASBOX -## ----------------------------------------------------------- ## -## Report this to https://github.com/sfilippone/psblas3/issues ## -## ----------------------------------------------------------- ## -_ASBOX - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; -esac -{ $as_echo "$as_me:$LINENO: checking for amd.h" >&5 -$as_echo_n "checking for amd.h... " >&6; } -if test "${ac_cv_header_amd_h+set}" = set; then - $as_echo_n "(cached) " >&6 -else - ac_cv_header_amd_h=$ac_header_preproc -fi -{ $as_echo "$as_me:$LINENO: result: $ac_cv_header_amd_h" >&5 -$as_echo "$ac_cv_header_amd_h" >&6; } - -fi -if test "x$ac_cv_header_amd_h" = x""yes; then + ac_fn_c_check_header_mongrel "$LINENO" "amd.h" "ac_cv_header_amd_h" "$ac_includes_default" +if test "x$ac_cv_header_amd_h" = xyes; then : pac_amd_header_ok=yes else pac_amd_header_ok=no; AMD_INCLUDES="" @@ -11895,13 +9210,9 @@ if test "x$pac_amd_header_ok" == "xyes" ; then psblas_cv_amd_includes="$AMD_INCLUDES" AMD_LIBS="$psblas_cv_amd $AMD_LIBDIR" LIBS="$AMD_LIBS -lm $LIBS"; - { $as_echo "$as_me:$LINENO: checking for amd_order in $AMD_LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for amd_order in $AMD_LIBS" >&5 $as_echo_n "checking for amd_order in $AMD_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -11919,52 +9230,23 @@ return amd_order (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : psblas_cv_have_amd=yes;pac_amd_lib_ok=yes; else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_have_amd=no;pac_amd_lib_ok=no; AMD_LIBS="" + psblas_cv_have_amd=no;pac_amd_lib_ok=no; AMD_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_amd_lib_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_amd_lib_ok" >&5 $as_echo "$pac_amd_lib_ok" >&6; } if test "x$pac_amd_lib_ok" == "xno" ; then AMD_LIBDIR="-L$psblas_cv_amddir/Lib -L$psblas_cv_amddir/lib" AMD_LIBS="$psblas_cv_amd $AMD_LIBDIR" LIBS="$AMD_LIBS -lm $SAVE_LIBS" - { $as_echo "$as_me:$LINENO: checking for amd_order in $AMD_LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for amd_order in $AMD_LIBS" >&5 $as_echo_n "checking for amd_order in $AMD_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -11982,52 +9264,23 @@ return amd_order (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : psblas_cv_have_amd=yes;pac_amd_lib_ok=yes; else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_have_amd=no;pac_amd_lib_ok=no; AMD_LIBS="" + psblas_cv_have_amd=no;pac_amd_lib_ok=no; AMD_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_amd_lib_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_amd_lib_ok" >&5 $as_echo "$pac_amd_lib_ok" >&6; } fi if test "x$pac_amd_lib_ok" == "xno" ; then AMD_LIBDIR="-L$psblas_cv_amddir/AMD/Lib -L$psblas_cv_amddir/AMD/Lib" AMD_LIBS="$psblas_cv_amd $AMD_LIBDIR" LIBS="$AMD_LIBS -lm $SAVE_LIBS" - { $as_echo "$as_me:$LINENO: checking for amd_order in $AMD_LIBS" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for amd_order in $AMD_LIBS" >&5 $as_echo_n "checking for amd_order in $AMD_LIBS... " >&6; } - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. @@ -12045,39 +9298,14 @@ return amd_order (); return 0; } _ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (ac_try="$ac_link" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:$LINENO: $ac_try_echo\"" -$as_echo "$ac_try_echo") >&5 - (eval "$ac_link") 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - $as_echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && { - test -z "$ac_c_werror_flag" || - test ! -s conftest.err - } && test -s conftest$ac_exeext && { - test "$cross_compiling" = yes || - $as_test_x conftest$ac_exeext - }; then +if ac_fn_c_try_link "$LINENO"; then : psblas_cv_have_amd=yes;pac_amd_lib_ok=yes; else - $as_echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - - psblas_cv_have_amd=no;pac_amd_lib_ok=no; AMD_LIBS="" + psblas_cv_have_amd=no;pac_amd_lib_ok=no; AMD_LIBS="" fi - -rm -rf conftest.dSYM -rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ - conftest$ac_exeext conftest.$ac_ext - { $as_echo "$as_me:$LINENO: result: $pac_amd_lib_ok" >&5 +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pac_amd_lib_ok" >&5 $as_echo "$pac_amd_lib_ok" >&6; } fi fi @@ -12206,13 +9434,13 @@ _ACEOF case $ac_val in #( *${as_nl}*) case $ac_var in #( - *_cv_*) { $as_echo "$as_me:$LINENO: WARNING: cache variable $ac_var contains a newline" >&5 + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( - *) $as_unset $ac_var ;; + *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done @@ -12220,8 +9448,8 @@ $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote - # substitution turns \\\\ into \\, and sed turns \\ into \). + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" @@ -12243,12 +9471,23 @@ $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then - test "x$cache_file" != "x/dev/null" && - { $as_echo "$as_me:$LINENO: updating cache $cache_file" >&5 + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} - cat confcache >$cache_file + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi else - { $as_echo "$as_me:$LINENO: not updating unwritable cache $cache_file" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi @@ -12298,33 +9537,36 @@ DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= +U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. - ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext" - ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo' + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking that generated files are newer than configure" >&5 +$as_echo_n "checking that generated files are newer than configure... " >&6; } + if test -n "$am_sleep_pid"; then + # Hide warnings about reused PIDs. + wait $am_sleep_pid 2>/dev/null + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: done" >&5 +$as_echo "done" >&6; } if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then - { { $as_echo "$as_me:$LINENO: error: conditional \"AMDEP\" was never defined. -Usually this means the macro was only invoked conditionally." >&5 -$as_echo "$as_me: error: conditional \"AMDEP\" was never defined. -Usually this means the macro was only invoked conditionally." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "conditional \"AMDEP\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then - { { $as_echo "$as_me:$LINENO: error: conditional \"am__fastdepCC\" was never defined. -Usually this means the macro was only invoked conditionally." >&5 -$as_echo "$as_me: error: conditional \"am__fastdepCC\" was never defined. -Usually this means the macro was only invoked conditionally." >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "conditional \"am__fastdepCC\" was never defined. +Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -n "$EXEEXT"; then am__EXEEXT_TRUE= @@ -12335,13 +9577,14 @@ else fi -: ${CONFIG_STATUS=./config.status} +: "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" -{ $as_echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} -cat >$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. @@ -12351,17 +9594,18 @@ cat >$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 debug=false ac_cs_recheck=false ac_cs_silent=false -SHELL=\${CONFIG_SHELL-$SHELL} -_ACEOF -cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -## --------------------- ## -## M4sh Initialization. ## -## --------------------- ## +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh -if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which @@ -12369,23 +9613,15 @@ if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else - case `(set -o) 2>/dev/null` in - *posix*) set -o posix ;; + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; esac - fi - - -# PATH needs CR -# Avoid depending upon Character Ranges. -as_cr_letters='abcdefghijklmnopqrstuvwxyz' -as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' -as_cr_Letters=$as_cr_letters$as_cr_LETTERS -as_cr_digits='0123456789' -as_cr_alnum=$as_cr_Letters$as_cr_digits - as_nl=' ' export as_nl @@ -12393,7 +9629,13 @@ export as_nl as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo -if (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else @@ -12404,7 +9646,7 @@ else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; - case $arg in + case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; @@ -12427,13 +9669,6 @@ if test "${PATH_SEPARATOR+set}" != set; then } fi -# Support unset when possible. -if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then - as_unset=unset -else - as_unset=false -fi - # IFS # We need space, tab and new line, in precisely that order. Quoting is @@ -12443,15 +9678,16 @@ fi IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. -case $0 in +as_myself= +case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. - test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break -done + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done IFS=$as_save_IFS ;; @@ -12463,12 +9699,16 @@ if test "x$as_myself" = x; then fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 - { (exit 1); exit 1; } + exit 1 fi -# Work around bugs in pre-3.0 UWIN ksh. -for as_var in ENV MAIL MAILPATH -do ($as_unset $as_var) >/dev/null 2>&1 && $as_unset $as_var +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' @@ -12480,7 +9720,89 @@ export LC_ALL LANGUAGE=C export LANGUAGE -# Required to use basename. +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr @@ -12494,8 +9816,12 @@ else as_basename=false fi +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi -# Name of the executable. as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ @@ -12515,76 +9841,25 @@ $as_echo X/"$0" | } s/.*/./; q'` -# CDPATH. -$as_unset CDPATH - - - - as_lineno_1=$LINENO - as_lineno_2=$LINENO - test "x$as_lineno_1" != "x$as_lineno_2" && - test "x`expr $as_lineno_1 + 1`" = "x$as_lineno_2" || { - - # Create $as_me.lineno as a copy of $as_myself, but with $LINENO - # uniformly replaced by the line number. The first 'sed' inserts a - # line-number line after each line using $LINENO; the second 'sed' - # does the real work. The second script uses 'N' to pair each - # line-number line with the line containing $LINENO, and appends - # trailing '-' during substitution so that $LINENO is not a special - # case at line end. - # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the - # scripts with optimization help from Paolo Bonzini. Blame Lee - # E. McMahon (1931-1989) for sed's syntax. :-) - sed -n ' - p - /[$]LINENO/= - ' <$as_myself | - sed ' - s/[$]LINENO.*/&-/ - t lineno - b - :lineno - N - :loop - s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ - t loop - s/-\n.*// - ' >$as_me.lineno && - chmod +x "$as_me.lineno" || - { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 - { (exit 1); exit 1; }; } - - # Don't try to exec as it changes $[0], causing all sort of problems - # (the dirname of $[0] is not the place where we might find the - # original and so on. Autoconf is especially sensitive to this). - . "./$as_me.lineno" - # Exit status is that of the last command. - exit -} - - -if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then - as_dirname=dirname -else - as_dirname=false -fi +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= -case `echo -n x` in +case `echo -n x` in #((((( -n*) - case `echo 'x\c'` in + case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. - *) ECHO_C='\c';; + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac -if expr a : '\(a\)' >/dev/null 2>&1 && - test "X`expr 00001 : '.*\(...\)'`" = X001; then - as_expr=expr -else - as_expr=false -fi rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then @@ -12599,49 +9874,85 @@ if (echo >conf$$.file) 2>/dev/null; then # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -p'. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || - as_ln_s='cp -p' + as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi else - as_ln_s='cp -p' + as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then - as_mkdir_p=: + as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi -if test -x / >/dev/null 2>&1; then - as_test_x='test -x' -else - if ls -dL / >/dev/null 2>&1; then - as_ls_L_option=L - else - as_ls_L_option= - fi - as_test_x=' - eval sh -c '\'' - if test -d "$1"; then - test -d "$1/."; - else - case $1 in - -*)set "./$1";; - esac; - case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in - ???[sx]*):;;*)false;;esac;fi - '\'' sh - ' -fi -as_executable_p=$as_test_x + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" @@ -12651,13 +9962,19 @@ as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 -# Save the log message, to keep $[0] and so on meaningful, and to +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by PSBLAS $as_me 3.5, which was -generated by GNU Autoconf 2.63. Invocation command line was +generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS @@ -12685,13 +10002,15 @@ _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ -\`$as_me' instantiates files from templates according to the -current configuration. +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. -Usage: $0 [OPTION]... [FILE]... +Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit + --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files @@ -12705,16 +10024,17 @@ $config_files Configuration commands: $config_commands -Report bugs to ." +Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ PSBLAS config.status 3.5 -configured by $0, generated by GNU Autoconf 2.63, - with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" -Copyright (C) 2008 Free Software Foundation, Inc. +Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -12732,11 +10052,16 @@ ac_need_defaults=: while test $# != 0 do case $1 in - --*=*) + --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; *) ac_option=$1 ac_optarg=$2 @@ -12750,14 +10075,17 @@ do ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; esac - CONFIG_FILES="$CONFIG_FILES '$ac_optarg'" + as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; @@ -12766,11 +10094,10 @@ do ac_cs_silent=: ;; # This is an error. - -*) { $as_echo "$as_me: error: unrecognized option: $1 -Try \`$0 --help' for more information." >&2 - { (exit 1); exit 1; }; } ;; + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; - *) ac_config_targets="$ac_config_targets $1" + *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac @@ -12787,7 +10114,7 @@ fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then - set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' @@ -12824,9 +10151,7 @@ do "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; "Make.inc") CONFIG_FILES="$CONFIG_FILES Make.inc" ;; - *) { { $as_echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 -$as_echo "$as_me: error: invalid argument: $ac_config_target" >&2;} - { (exit 1); exit 1; }; };; + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done @@ -12848,26 +10173,24 @@ fi # after its creation but before its name has been assigned to `$tmp'. $debug || { - tmp= + tmp= ac_tmp= trap 'exit_status=$? - { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 - trap '{ (exit 1); exit 1; }' 1 2 13 15 + trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && - test -n "$tmp" && test -d "$tmp" + test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") -} || -{ - $as_echo "$as_me: cannot create a temporary directory in ." >&2 - { (exit 1); exit 1; } -} +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. @@ -12875,7 +10198,13 @@ $debug || if test -n "$CONFIG_FILES"; then -ac_cr=' ' +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' @@ -12883,7 +10212,7 @@ else ac_cs_awk_cr=$ac_cr fi -echo 'BEGIN {' >"$tmp/subs1.awk" && +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF @@ -12892,24 +10221,18 @@ _ACEOF echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || - { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 -$as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} - { (exit 1); exit 1; }; } -ac_delim_num=`echo "$ac_subst_vars" | grep -c '$'` + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || - { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 -$as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then - { { $as_echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 -$as_echo "$as_me: error: could not make $CONFIG_STATUS" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi @@ -12917,7 +10240,7 @@ done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 -cat >>"\$tmp/subs1.awk" <<\\_ACAWK && +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h @@ -12931,7 +10254,7 @@ s/'"$ac_delim"'$// t delim :nl h -s/\(.\{148\}\).*/\1/ +s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p @@ -12945,7 +10268,7 @@ s/.\{148\}// t nl :delim h -s/\(.\{148\}\).*/\1/ +s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p @@ -12965,7 +10288,7 @@ t delim rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK -cat >>"\$tmp/subs1.awk" <<_ACAWK && +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" @@ -12997,23 +10320,29 @@ if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat -fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \ - || { { $as_echo "$as_me:$LINENO: error: could not setup config files machinery" >&5 -$as_echo "$as_me: error: could not setup config files machinery" >&2;} - { (exit 1); exit 1; }; } +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF -# VPATH may cause trouble with some makes, so we remove $(srcdir), -# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=/{ -s/:*\$(srcdir):*/:/ -s/:*\${srcdir}:*/:/ -s/:*@srcdir@:*/:/ -s/^\([^=]*=[ ]*\):*/\1/ + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// s/^[^=]*=[ ]*$// }' fi @@ -13031,9 +10360,7 @@ do esac case $ac_mode$ac_tag in :[FHL]*:*);; - :L* | :C*:*) { { $as_echo "$as_me:$LINENO: error: invalid tag $ac_tag" >&5 -$as_echo "$as_me: error: invalid tag $ac_tag" >&2;} - { (exit 1); exit 1; }; };; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac @@ -13052,7 +10379,7 @@ $as_echo "$as_me: error: invalid tag $ac_tag" >&2;} for ac_f do case $ac_f in - -) ac_f="$tmp/stdin";; + -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. @@ -13061,12 +10388,10 @@ $as_echo "$as_me: error: invalid tag $ac_tag" >&2;} [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || - { { $as_echo "$as_me:$LINENO: error: cannot find input file: $ac_f" >&5 -$as_echo "$as_me: error: cannot find input file: $ac_f" >&2;} - { (exit 1); exit 1; }; };; + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - ac_file_inputs="$ac_file_inputs '$ac_f'" + as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't @@ -13077,7 +10402,7 @@ $as_echo "$as_me: error: cannot find input file: $ac_f" >&2;} `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" - { $as_echo "$as_me:$LINENO: creating $ac_file" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. @@ -13089,10 +10414,8 @@ $as_echo "$as_me: creating $ac_file" >&6;} esac case $ac_tag in - *:-:* | *:-) cat >"$tmp/stdin" \ - || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 -$as_echo "$as_me: error: could not create $ac_file" >&2;} - { (exit 1); exit 1; }; } ;; + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac @@ -13120,47 +10443,7 @@ $as_echo X"$ac_file" | q } s/.*/./; q'` - { as_dir="$ac_dir" - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || { { $as_echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5 -$as_echo "$as_me: error: cannot create directory $as_dir" >&2;} - { (exit 1); exit 1; }; }; } + as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in @@ -13217,7 +10500,6 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= - ac_sed_dataroot=' /datarootdir/ { p @@ -13227,12 +10509,11 @@ ac_sed_dataroot=' /@docdir@/p /@infodir@/p /@localedir@/p -/@mandir@/p -' +/@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) - { $as_echo "$as_me:$LINENO: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 @@ -13242,7 +10523,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g - s&\\\${datarootdir}&$datarootdir&g' ;; + s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF @@ -13270,31 +10551,28 @@ s&@INSTALL@&$ac_INSTALL&;t t s&@MKDIR_P@&$ac_MKDIR_P&;t t $ac_datarootdir_hack " -eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \ - || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 -$as_echo "$as_me: error: could not create $ac_file" >&2;} - { (exit 1); exit 1; }; } +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:$LINENO: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined." >&5 + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' -which seems to be undefined. Please make sure it is defined." >&2;} +which seems to be undefined. Please make sure it is defined" >&2;} - rm -f "$tmp/stdin" + rm -f "$ac_tmp/stdin" case $ac_file in - -) cat "$tmp/out" && rm -f "$tmp/out";; - *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ - || { { $as_echo "$as_me:$LINENO: error: could not create $ac_file" >&5 -$as_echo "$as_me: error: could not create $ac_file" >&2;} - { (exit 1); exit 1; }; } + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - :C) { $as_echo "$as_me:$LINENO: executing $ac_file commands" >&5 + :C) { $as_echo "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5 $as_echo "$as_me: executing $ac_file commands" >&6;} ;; esac @@ -13302,7 +10580,7 @@ $as_echo "$as_me: executing $ac_file commands" >&6;} case $ac_file$ac_mode in "depfiles":C) test x"$AMDEP_TRUE" != x"" || { - # Autoconf 2.62 quotes --file arguments for eval, but not when files + # Older Autoconf quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. case $CONFIG_FILES in @@ -13315,7 +10593,7 @@ $as_echo "$as_me: executing $ac_file commands" >&6;} # Strip MF so we end up with the name of the file. mf=`echo "$mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile or not. - # We used to match only the files named `Makefile.in', but + # We used to match only the files named 'Makefile.in', but # some people rename them; so instead we look at the file content. # Grep'ing the first line is not enough: some people post-process # each Makefile.in and add a new line on top of each file to say so. @@ -13349,21 +10627,19 @@ $as_echo X"$mf" | continue fi # Extract the definition of DEPDIR, am__include, and am__quote - # from the Makefile without running `make'. + # from the Makefile without running 'make'. DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` - test -z "am__include" && continue + test -z "$am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` - # When using ansi2knr, U may be empty or an underscore; expand it - U=`sed -n 's/^U = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the # simplest approach to changing $(DEPDIR) to its actual value in the # expansion. for file in `sed -n " s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ - sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do + sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g'`; do # Make sure the directory exists. test -f "$dirpart/$file" && continue fdir=`$as_dirname -- "$file" || @@ -13389,47 +10665,7 @@ $as_echo X"$file" | q } s/.*/./; q'` - { as_dir=$dirpart/$fdir - case $as_dir in #( - -*) as_dir=./$as_dir;; - esac - test -d "$as_dir" || { $as_mkdir_p && mkdir -p "$as_dir"; } || { - as_dirs= - while :; do - case $as_dir in #( - *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( - *) as_qdir=$as_dir;; - esac - as_dirs="'$as_qdir' $as_dirs" - as_dir=`$as_dirname -- "$as_dir" || -$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ - X"$as_dir" : 'X\(//\)[^/]' \| \ - X"$as_dir" : 'X\(//\)$' \| \ - X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || -$as_echo X"$as_dir" | - sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ - s//\1/ - q - } - /^X\(\/\/\)[^/].*/{ - s//\1/ - q - } - /^X\(\/\/\)$/{ - s//\1/ - q - } - /^X\(\/\).*/{ - s//\1/ - q - } - s/.*/./; q'` - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" - } || test -d "$as_dir" || { { $as_echo "$as_me:$LINENO: error: cannot create directory $as_dir" >&5 -$as_echo "$as_me: error: cannot create directory $as_dir" >&2;} - { (exit 1); exit 1; }; }; } + as_dir=$dirpart/$fdir; as_fn_mkdir_p # echo "creating $dirpart/$file" echo '# dummy' > "$dirpart/$file" done @@ -13441,15 +10677,12 @@ $as_echo "$as_me: error: cannot create directory $as_dir" >&2;} done # for ac_tag -{ (exit 0); exit 0; } +as_fn_exit 0 _ACEOF -chmod +x $CONFIG_STATUS ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || - { { $as_echo "$as_me:$LINENO: error: write failure creating $CONFIG_STATUS" >&5 -$as_echo "$as_me: error: write failure creating $CONFIG_STATUS" >&2;} - { (exit 1); exit 1; }; } + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. @@ -13470,17 +10703,17 @@ if test "$no_create" != yes; then exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. - $ac_cs_success || { (exit 1); exit 1; } + $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { $as_echo "$as_me:$LINENO: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi #AC_OUTPUT(Make.inc Makefile) ############################################################################### -{ $as_echo "$as_me:$LINENO: +{ $as_echo "$as_me:${as_lineno-$LINENO}: ${PACKAGE_NAME} ${psblas_cv_version} has been configured as follows: MPIFC : ${MPIFC} diff --git a/configure.ac b/configure.ac index 4310397ae..b373eea5d 100755 --- a/configure.ac +++ b/configure.ac @@ -479,11 +479,30 @@ dnl FDEFINES="$psblas_cv_define_prepend-DMPI_MOD_F08 $FDEFINES"; fi fi -PAC_ARG_LONG_INTEGERS -if test x"$pac_cv_long_integers" == x"yes" ; then - FDEFINES="$psblas_cv_define_prepend-DLONG_INTEGERS $FDEFINES"; - CDEFINES="-DLONG_INTEGERS_ $CDEFINES"; +dnl PAC_ARG_LONG_INTEGERS +dnl if test x"$pac_cv_long_integers" == x"yes" ; then +dnl FDEFINES="$psblas_cv_define_prepend-DLONG_INTEGERS $FDEFINES"; +dnl CDEFINES="-DLONG_INTEGERS_ $CDEFINES"; +dnl fi +PAC_ARG_WITH_IPK +PAC_ARG_WITH_LPK +# Defaults for IPK/LPK +if test x"$pac_cv_ipk_size" == x"" ; then + pac_cv_ipk_size=4; fi +if test x"$pac_cv_lpk_size" == x"" ; then + pac_cv_lpk_size=8; +fi +# Enforce sensible combination +if (( $pac_cv_lpk_size < $pac_cv_ipk_size )); then + AC_MSG_NOTICE([[Invalid combination of size specs IPK ${pac_cv_ipk_size} LPK ${pac_cv_lpk_size}. ]]); + AC_MSG_NOTICE([[Forcing equal values]]) + pac_cv_lpk_size=$pac_cv_ipk_size; +fi +FDEFINES="$psblas_cv_define_prepend-DIPK${pac_cv_ipk_size} $FDEFINES"; +FDEFINES="$psblas_cv_define_prepend-DLPK${pac_cv_lpk_size} $FDEFINES"; +CDEFINES="-DIPK${pac_cv_ipk_size} -DLPK${pac_cv_lpk_size} $CDEFINES" + # # Tests for support of various Fortran features; some of them are critical, diff --git a/docs/html/footnode.html b/docs/html/footnode.html index 57ffc7438..31eb52aac 100644 --- a/docs/html/footnode.html +++ b/docs/html/footnode.html @@ -177,7 +177,7 @@ sample scatter/gather routines. HREF="node133.html#tex2html32">5
Note: the implementation is for $FCG(1)$. diff --git a/docs/html/img1.png b/docs/html/img1.png index 2ac27f9619e5eb27f3ca81d3b0f77011c78ffb37..adecd9a93236141cf8f5ef90448d6e9cd2f2a5ea 100644 GIT binary patch delta 176 zcmX@XxSw%?cs)N0GXn#Id~A>mkkSh9332`Z|38rV?%lh)ckiA#b7uGM-K$ounmKc3 zSy@>}M@MREshjVkHc*{kxDk-1MKD@EKnrQ_F249*aCre5QIhIUeVg7wA bjE!N5Hdp?31)23g^B6o`{an^LB{Ts5j-)-| delta 185 zcmdnbc!F_)cs(BrGXn$TVz!O?3=9nF0X`wF|NsA=Idf)tdHK6{?~IL&1qB6HtyFtfSD&~Skfqwowyp#V3-YkZ=3uOXf}hVtDnm{r-UW|=PyCU diff --git a/docs/html/img10.png b/docs/html/img10.png index 41dbbad67f5d00bdffd4d5a0ef6ab3537fd89bbd..c2ac54166ce9596e146d3433a9c7beca2fb75b4d 100644 GIT binary patch literal 358 zcmeAS@N?(olHy`uVBq!ia0vp^?m#Th!VF?LpWOze3<7*YT>t<74`jZ3_wMf9yJyav z*}Z%Bs#U9I&YW3RR@Twck(!zs5)$I<>}+IYq^PJUARv(RQhgUt17k^$UoeBivm0qZ z&J#};#}JF&)IFn4L1d}n2ekvD8=Y7sBc6y#%u^6CH27hhpp_(?e!;^b>`Jez;PLhqr+H3v z`574)urAPi6nW*N9itkTl54}H1ikExCzmcHY*46YYQD!B)}pkH-QcQ6myBqGnNs9& z)|4{_4x97Ln3<0=&Cr;zCGTkp|5erwpZS3PW$<+Mb6Mw<&;$V1 C+=V#+ literal 404 zcmV;F0c-w=P)Hh-PMH0000)L`2=)-6A3)ySuv-E6N)H z0004WQchCOO@Ms1W0EQBMt(p4&z~a7%9W0CXEc3}oOwfIcdgAd3JDD|t z8TF|h<9Dg}C5JT8iioCH)uh}?{otLT21 zTj)s|f>-OIXC4AD9^&PFC0HAS*_$-VmuYZ4dJBoAM}&2Ev*ER45JzwRUHSqS!Qf3A yw0V0sM@=_)&qhoMZcb|Dy$*UU&2#Sue-RIimk8_{iK!?60000S diff --git a/docs/html/img100.png b/docs/html/img100.png index 89a17445a1029668b2dc5d19d19653f60ae4a6e7..1ef36aeedc100d28f45050fca71747bc693c9c9e 100644 GIT binary patch delta 159 zcmdnQxQ=mxcs)N0GXn#I(s|=5Af*-H6XN>+|9>F!?%lg*&Yao3d-u$lGt0`#IyyR1 zQ&U4iLY$qQjf{*G6%_>p1itRHGXW}PED7=pW^j0RBMrzg@^o#=I0gOIZ8$7q$N_g_{FnmvE+wnH4tPH4~!PC{x JWt~$(695tJIo<#O delta 163 zcmZ3-xQTIscs(BrGXn$TyeStv85kJU1AIbU|Ns9#bLPzQ^77EoP-A1`GiS~S3JP{~ zbfl%F0hQdndsj(GY4`5kavAO4fqcf2AirP+hi5lHl9rw>jv*W~lM@^m$|O$q3M4Zp zxv7}m38-TfP-pnaref*lU22fas1}*tsQHY|Ky)XAjEmf-Ye@+V40AbHXIzPR_#S8q NgQu&X%Q~loCIBLZH&6fo diff --git a/docs/html/img101.png b/docs/html/img101.png index f539ffeb3309da75bba063bf2f46ca8d6c155676..c340433136ef2e9922924bb7fa74b090863399d7 100644 GIT binary patch delta 316 zcmV-C0mJ_50?z`F9De|UwqSe!001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCh=H{mXcR{W5VQhqwYbFkfFTDe&GBFY149RrW>)S3pu0Mt(#)bj z>0`)-^BVx&brsBXWnkEwz`!5`WOAPYf}=o&9|ONJlK|MaK%I#S46GMWoW>B#$$9`N z!(j2lfPowCNi`_g&R~|P1ZNR{!z@UuaGdDJ23z<Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCO&ifeiv6GJt`Bm4QhKuSy06CUz);GX%t&0Ae;U>3?%ufEW)5XvPLqI1%gv zKx26r7!tsoOKc!=5rYB`)Mn;y3&=2^0N}Zx184Jt>@Pr)1O?jy0VqfC69B_y7ytk@4MF3fjV@OC+i(&K=(Q0n+JuKf3e zrf(L+7KY1e3;YSMhhv`(gdEBaUnJN=v3=DR2XfyhCQ=%>V73Ol2!~amLF^sago7gG zB%7!vSGt%!cr`|TS(v^o(^FjYu)gD_@G-B=b&c%NXkNy+GyAyy^~?1I%!NuLrvO65 P00000NkvXXu0mjf_nXld delta 521 zcmV+k0`~pp1C<1j7k?lG0{{R4J&3cf0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*IlSxED zR5*>@QY}xzP!v7umUe63_Lg}=a-@F91TcY1pJ?(MzjUf|0tgGEfU*D;=#gdC4IKmtoaB~xRj znytal5ZdNlhwdaw)1gaHzfUz`c>`HONhfpIhzw=MlOc3hCC|YsBB0hE2-Ix&h}5RQ zHhO7%nU_>kvws-wzpMDWDTE`|Hkz5}ayTn_NoeQ`LUE3@K+npoE~hCI0e*ZGtWrkXV|2p;IxM`;S|%6M;s2;_2w zg{O;Sh{nX^1O{eS1-^s>EIJNniW?ptVA3gaIKZVO<&f1SCd06iKOwxGA;;lQ18>S2 zX?=0&!^UkaY;Aj(74Ps^@<=OasTmju8nLKnBvde{Bug~7Z7_Cjv5=6Ekd(N=-1o!a zLu2iZ1jY*oxgFNbVCDWP!4#?ZYKNqRg`$oaJDc35SO=+$#t4hn#)VTH*&`pB%y`0L z9g)Z69I%k@upL`lIU7&Sf`CVl=NzzY{K|Ae+(GP$v2kR)rNL*@_HXP6~! zYrmGTl8|`DX<(qGAbI`^gG<%o9Y>i{47Qm#6f-b*UROVw#=5{9=w}8`S3j3^P6R49>SV4xjH24YSqn^OTyu?H})IWRXs#Pkfnlm!C=ZvsOr ziq;k|sf{9b0Zj6M4RUW|U}?`{U^&3RUctb?kpL2#ki+1skjKEox literal 368 zcmV-$0gwKPP)SU;qOFAYQ-#2MR#^fdK_@GhhcC{4f^NGlmTe44gRB zAp@2K5ZPb=Bvcqa2yFNUv4M{-;Q*TeP>vO3KO+Of1tQGC33wUUfFwH*A7E#JiZy_} z#?8vg!0?@+0O({UAnPv3*%$ad5)x_|4lpo)Tm@8=z`zA^`pTOiYFzMLDz@pgMz;KL#|1$%_ACM65g;oYV2KEa;pL|#akE{0#I~ZoM0mZl$ zTmT0I(24^LNsU4c3>pkv9~l^gKtf`EP^)-A1j_+bH}wMXH!Ay+6aWBqO)Pn?2Tg+j O0000_*n^m;Yv&I93O8jq;rA}IBl$r5DPyux4`V(4L>6S4j=MXFf(Ru77}Lm;AEKnNpSC1VdsB9 PI~Y7&{an^LB{Ts5+M7}s literal 228 zcmeAS@N?(olHy`uVBq!ia0vp^VjwmPGXn#oM$hJBK#oCxPl)UP|Nm#soLOF89vT|@ z?%g|MW8*Vt&Ik$$u3ELKqoX4&Ee)v9#l_|B-MdOkO1pROmX}qW3KU{23GxeOaCmkD zB%kEz;uyj)GdY2QiJgt*LG%ZPbI?0wP*4dWH_+TiD8#8Gw9eT%UGCayn)MLgASv2gwd7iO>+`1rZO;G Xnjxg1Sth6fw2i^j)z4*}Q$iB}$i+)j diff --git a/docs/html/img106.png b/docs/html/img106.png index bd84d15a13c55f0d1ca4f209b9dbf12f7d15f537..838f753bf3de5157f010965de6e1fb6151872cb1 100644 GIT binary patch literal 309 zcmeAS@N?(olHy`uVBq!ia0vp^20$#w!VDy5bTxbe2?Y3rxc>kDAIN<7?%mzHch8(T zvwQdMRjXFboH?_stgNG>BQ-TOBqYSy+1bd*NKsKyKtLerrTQ+Q2F8*gzhDN3XE)M- zoXwstjv*QolM@z5C)jnIG1hn6P~1>a#?W$hTf=Eay^D-Td}28h%;qz`X5Dcl)F3jL zK}l9pqNPFP`K3)|Y-)@hHKl?RI8qV>Sc6XPMkxtw(fb;{9%_;BQ>p)8(XjT3UV@!iLU7lU!fDRe*cMz! zNC-$uFmm7%y2@~c;q(gzCN`Y|CP2V4`-sK?euk4QstQ%rJcohKXYh3Ob6Mw<&;$V4 CRdCq= literal 340 zcmeAS@N?(olHy`uVBq!ia0vp^`amql!py+HXsMCK2;>+9_=LFr|NnpH%$eoo<)NXW z@7}#LHa0$U=8T}A;Hp)tIyySi($atmU0hu5-o2}&q_lhYZh2Y7sX!sdk|4ie28U-i zK=PM7T^vI+CMG8^F!>1_Jj}q()pJLqhK-fYPFbOFCZlx%dlDlXpC6lBox*Fb!|WS0 zE=$Us+W7K1dk`PD#1CE}nFbw4wz@W69vYZWLWL!%?)O-uOd4!^Uh$HDi-T*T^jsN)2=qZfF;{ kh~4C4)Y~EJEXTl*HA%(dr`P=!pzjzwUHx3vIVCg!07F`EA^-pY diff --git a/docs/html/img107.png b/docs/html/img107.png index 6c716f7e4178c36efee52549aad19407b2ea3fb7..91be9c99418882c77d75c665655a445e70d53b89 100644 GIT binary patch literal 257 zcmeAS@N?(olHy`uVBq!ia0vp^@<7bT!VDx;xo(*NDT4r?5ZC|z{{xxt-o3kf_wJc9 zXLj%2y=v8}nKNgWm6dgLbfl)HhJ=JTJ3AX087V3%3J3@!y;R=?)WBF0o>B@kd&Ar!6Pw4WQK%;6$9I0sY8?5CS3*&MYr44-E}{ z_wJpsvGJKRX9NWWSFKvr(b18XmIhSl;^K1m?p-A%rQN%C%gZWG1qv~i1o;IsI6S)n zl5g~MaSY*@nVjIjUc)UBIbp{iK~5$fov1Ls$^`kUt+I9b||$o%*%OCB2=>vB$o ziMM&yF!9XdnJg(G!Fs?;NAi_zB$vdud+9N!*B@YDSY;#m{CfG!zd*+@c)I$ztaD0e F0sx<5TcrR1 diff --git a/docs/html/img108.png b/docs/html/img108.png index 660cca8c7ec796eebb489d2e672e35a6881cb687..bd8bc58ddc602096cd76576b63138ee9eb253d17 100644 GIT binary patch delta 169 zcmX@axPx(mcs(BrGXn#|%gGP!11W<5pAgso|NjG-@7}$;d-v{{GiP@1-o0wos+luq zmX(!tbabSqriO%sI6FHV85t=mDhdb)B)wGM1=PS;666=m;PC858jxe=>Eal|F*7+q zfw5wWF2f|9={MvUH1{$237ijX+|A%|)bPV>22J@k3#BrJqf^6Xvt4>{B;f!916w|a VX~@Q3p+F-TJYD@<);T3K0RTK$KaBtY delta 179 zcmdnNc!+U=cs(x*GXn#o1jC}|3=9mq0X`wF|NsA=Idf)td3k7P=(~6C&YU?TC@8pU z)vAt;jML9-f#SMjf7>etClg_BG)*gd47`WIw~C f(DhJKnVDgR8JFe}SGDCp^B6o`{an^LB{Ts5I*mS} diff --git a/docs/html/img109.png b/docs/html/img109.png index 1aaed1e97dc2f8e3957f687bf71d97c2d9f312c7..23cab561de34e4389525264692198d2e8820051c 100644 GIT binary patch literal 624 zcmV-$0+0QPP)& z&)l1H&IRToy{0vo!Mtg!>t|j!kVjEd)JzRuQicO7%B5Prfi7Vr-fAe1CPzveR`{DT z4Dm6)^)dK^L!@4#50dr^Qw&S_^gdKD?Y))XYfQ6BBM1MWip*O)g?;`8cFYkz$qV~5 z#OAvTV(3Ls^6z?4T{A2!U`w#^?rz~l;{;B`5xz;f=f?J(J0j-n#PG<b^-w%`bvs zRZ}`+<8^O0Mi>WfL{X3&9*fvV{V6fLwawwNP4mNW(ZZ2n<1Kd%VrSH*GL<_al|%MA zrt<6;xpY@gsC3Ns@KWHO$E71|N~gZ#=ixATxS)sImALl7Zi!9wy^O)Tu~v77%apt1E#Q0%s+4;ML@;)W_HZod1!HkAmn4` z&6{uD%zN|Z?Ernmuu4V1!JlAEV2_wo28;qAkdV0^`SwfNdrUBDwOW6i_MOC4^3u&E z?B~#)N_VoH4yg%yT(^IRORaF#ft7=d$*km$fa|=>H9Qx4=m7KVEO1kY#oKY>Rk+eu zz`IJ#w50|c zEYL%Yi~Cwu9;shv%5aNicb-av*ZGk7`y4CMjSOzw|4!?l)75J{V+Ql8rHoKUYc#G;Ta81!+J@YfRLlsAwDMA*u z@doRl(kpsU9WB2H+up$pPAa4A+lEGuedEq?PESXV3a_I%KM7x8SFoGtv52N%U{uzD(I>=0tN%ZW@b=Tz!Zf6PB7WPP<7_a2`~cz8W`AKYJZ&jiXqCpW&;DmR3MWB zBA}DNdVm40$^fQHauL%H4ADw80S4wz2)$_xya{l5GiQst-s zbT)=4!)yiyQ3fP81O31-!vM{7Kt&u2Fhm)yGq3V|YFmOCx&PcKW5mrF3tN=}~f@=V#C8XMf>AK2000q(c2u_!6ukfd002ovPDHLk FV1goRuT1~| delta 513 zcmV+c0{;En1C9ic7k?lG0{{R4LRq0+0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*Ij7da6 zR5*?8R69$7f@n}3Vw=Fr(G6bG?O5%EDB zVwZw03c8AaKA>K+JwU;iPLFh*z(g?FZ@59^F70%|mG5zT+9FN_+p zOtS)*mVa&rmE}*Go+K@yq(e!22Tv)gZ1~MIvq+X5xV7x6Nej-H7E-Sp!}`g>#uybY zQfs;-v0>vlrh0Cp1?-1jAYV=JUR1UcRP_=$ zE$WrLt2)C~WldzSVyakb=?(IM2i|F*Vslj!Pf*R6iZ5Uh;t3mf!*Q;AIeQSg{5}s>fpRD61%DdD)uI2dG5!?a0<=ID0%>kLGPDnX#0um?k3~6@tP**v71wrMUOUv3B7=Pj~g#y{3K0tz_0|;7i zDNpWIh+|-A@+bhZ13Czr9V6Z9t|t7qDKKz|zdz0P^KbWYrP(+Zh@i7&tyKF!VEkDIkx# zfcaQ}2A8Y?NI8WAy4|b}Xgp>H1|FRAND2_3t#SY!H8yDM S?9o5~0000I0`&rr7k?cD0{{R4Kps6!0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*H^GQTO zR5*=eV1NRJ4GbJC3|K*e0s{j}0v3r4Fa{f#!^FtIAaMb^8Go37gMon&&iTNk1a$@* zL>OdN!)h0ZAU_ZjZ7vaD0}cU%I6EhU3l@zZsOSiCKmnL!B33zn0fUl~KC;MFZblvk z240N7QZ)P)B4KND2W zsL?-(fnl|X0$`B+VHH8;9}F4Nfmw7Jh|RSC7>P_uO3;YMrkw2ogW(01CE(P|^$}S{ zXp=s}aRvrfpuIs5O8o-^a|46@g}Hezu=|Ds4{sFU007wBC`$-gvkCwJ002ovPDHLk FV1l!9h)@6k diff --git a/docs/html/img111.png b/docs/html/img111.png index ea78705b71ed2e7cb82e4cbbfc9efb37caa1bfdb..c045469108211996b42a222e1e6ef6b1e8c472f8 100644 GIT binary patch delta 116 zcmZo;>|~rElgp6LKBbP0l+XkK2^1(> delta 113 zcmeBVY-5}tlf@{(u;@7h1A|b2Pl)UP|Nm#soLOF89vT`76x+Rf_te<=yg(LXNswPK zgTu2MX+VyWr;B3<$IRpe2L?A*fs;(mJZA*tBpx$)F>-91z}#}om65^j1moX;7{hR& OY6eeNKbLh*2~7Y%o+E+) diff --git a/docs/html/img112.png b/docs/html/img112.png index 74f211e1e3c6cc60031f040e98a014fb4b6367f3..854b45831b8d90060367329ed56a8fc8ac94381b 100644 GIT binary patch literal 253 zcmeAS@N?(olHy`uVBq!ia0vp^Qb5el!VDxi>JME7QU(D&A+G=b{|7SPy?b}}?%gwI z&g|a3d)2B{GiS~$D=X{h=txaX4G9Txc6K&0GE!7j6c7+dda1q(sDZI0$S;_|;n|He zAg9{X#W93qW^#f8^9>G#&o}rKK3hmlsNBQo(6qPdp?0(TO(r(i2>~nk4;M}I&f%9R za@fewb~*DZx;=hCPC}M&i+pNPZs% yPdV@82VSdvlkMaf!d4wP@Zdgec5OG^VPba8RHd-txAlG5(oyX9pSrvil-OM?7@862M7 z0Lj;Tx;Tb#%uG%If?EtK67Mt(8W?}GinD1vNcq9AXq}_xiHyu<45rT* zng6rJPUm)DX4zvI*}(MY&K)Q54X+p)*RxNkv{7jNGhdQPa*|Z3C@R7(8A5T-G@yGywoy Ccv?A+G=b|9|)H-QBx)&zw24 zd-v{Dt5(gNIkT*+tfQkNH8nLPB*fX-*~rL9QBhGqK%ke;BoU~Qu_VYZn8D%MjWi(V zuBVG*h{nX^ga!Hup$Q2O8jN@+90`_?Xqw4&z-Jyqi-E@r4QI|a!#4?ggCri=But8C z@Yt}_xTGq@aEa&!wJ$~y#tf1?ZxklSu8F*AUb5LD|AE(pExE0LtxY1W!!o9m zajwHD=@n*-DesK}JNCYjSU?2ia_`tvmq__zxYaaR57oN`Qrd0c24wn8VLd-~gAI0CEun zM}qi--y9AF`~@IKZs1^GT)?n__W~#&az6kC6b`Uo;DPJ8z`%fTC>H~R0`(k90hofs z_HqDviRl7{8r}n7Y8jZ6U%)s~(17C?gCfTRo(~NCpBWhbfW-N^7F^L{VE8bZ;{k&L zFbF=Zf+dMnYz$j~)E4#&{0YE-;#zP48mSfuoC-inaAm(51Lp(=u8#~1LYOYp2N5g> kFeO+(3F#X-o~8=`0F-GlG@kMKk^lez07*qoM6N<$f~2gJ7ytkO diff --git a/docs/html/img114.png b/docs/html/img114.png index fdfd3db7a7accefb6aa96c9dfe408ed99ccfa6f5..5464f36430aeb5076565585b928c96c70aa77118 100644 GIT binary patch delta 220 zcmV<203-j00_y>g7k?210{{R3F{7bA0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HX-Pyu zR0x@4U?3H+mzIYYz*oD(I%z<#h5!Uh10 W)e`nTmSDyJ0000!6pVi ysW(tw3xhSn044?oEjZ`pA_hh)J**b3LIwb|9wHFc=EV>I0000jjyBlx~1ei0l9V|AEYR@7~?Ld-u$l zGrM>1UbSk~%$YOG%E~%AI#N?pLqbBFot=%0j1(0W?aVr7097-V1o;IsI6S+N2IM4o zx;TbNOifN$z?Gn9?(i(lP=|5S8-tC8sD8yJ2FVdQ&MBb@0D2=%7XSbN diff --git a/docs/html/img116.png b/docs/html/img116.png index 4c5591100d17b9afb1b86907d6640487850c0b0e..98eb28ffd99abc13182d4f0f147244ae607b6c7e 100644 GIT binary patch delta 207 zcmV;=05JcQ0^R|T7k>^200000@=uuC00002bW%=J0RLN&BDDYj0GCNbK~xx()lX3s z12G7zgjzTYXQ3AE&B0kf0|xei1uS5p7O+qY8MN1Z?tl3qX@Jmz-zb0J^KC3w5GP@Q z2mvbKWBKaTzzyi<0M57d;Fn<3>10{{R45ovV|0000sP)t-s|NsA^qobLbnRj=0RaI5)?(Q=) zGtA7)5fKrps;Y>Hh-PMH0000)L`2`;-`(BaA|fKYySuvE-v|Hz00DGTPE!Ct=GbNc z004|hL_t&-m7P%A4#gk{>qOjidYu3NvnyVbJ?v$t#y}8k3w|(=WyAuH2O5tEUa&); zBUM4GZ#|G$;988HSuX@K8Hujhk4TRHIP!7+vVw!fEx~G-_asT~x$h#BB1-#<@GD{! zk3^ei;$n_ptn^F&8dgW{&M#YP%N2zVOxuz-w_WIS4{Sa7O`gv;kHQ0my1+nq00000 LNkvXXu0mjfqz7_a diff --git a/docs/html/img117.png b/docs/html/img117.png index 8e8e8c7b617ef9d65016d9de0d80b87d8db2f0da..507a235c57c99fe63b3fa5dd287d4bfbc9127ca0 100644 GIT binary patch literal 368 zcmV-$0gwKPP)Hb{LX@g&2&Mrs>RB7eQ^mQotet`NuWCSf1H-KF zi~@uzuna@|rBEO{xmO{MfkUO8HRJ%B#U<7U2vuMih9(b?#(?b%ISdRe39K9qtlR}` z2Y_lqBbSB-!(=}r~=6_D1a@*4v31OQ846yAQ3=-nyLU)=)kjc;Yff1ORy%KnP7(N&>q$5=EGYha4fMh_N$qZB3 z7`z<#8BSbbd%$3L0by1i1G6kx1_+)ptQX+C_O5}!{sS|RKvHGF!2B01GYVh;05K>y ULaoNwV*mgE07*qoM6N<$f^M#jssI20 diff --git a/docs/html/img118.png b/docs/html/img118.png index 56826b8bf01bdaa32853861434dfdbb451e4b900..40fe13030b096468455be53f930715b829e4d546 100644 GIT binary patch delta 188 zcmcb|c$#s7cs)N0GXn#I^ok}$AY~BX6XN>+|9>F!-Me>p@7_Ig=FINhyH~ARHFM_7 zva+&{j*isS)R2%6XJ=<4BO^scMF9bUq?hWufEpM}g8YIR9G=}s19Ch)T^vI=W+o>n zNNxD8lNfiIDNV~SA%aQpN!5X842c^%mL3SXr`@no%~Z-kQs*acz%=#a>?;D8H(Rtk oJ$hh+_?eDhxd;AjnA*t5z%qf)W5tyQ6QHRKp00i_>zopr04a`1>Hq)$ delta 207 zcmX@jc#m;{cs(BrGXn$T^3RDv3=9kg0X`wF|NsA=Idf)td3k7P=(~6CjE#-YoH-*X zD7b3Xs*aA1w6rv!LKhd8yLay@DJkvVy<1*ZaVk)Vu_VYZn8D%M4Ul|{r;B3<$IRpe zAV_LpP-SB?U!}!XRqPp1h&cd2LeggS#AQe^%{0AhGuR0S1N-0lc5xs+uc+7BP6b`njxg HN@xNALU~R} diff --git a/docs/html/img119.png b/docs/html/img119.png index e205726f752de2f3b9c3206e5602974187753a72..12d6772d465166b77141735042fae03911b97271 100644 GIT binary patch literal 237 zcmeAS@N?(olHy`uVBq!ia0vp^Qb5el!VDxi>JME7QU(D&A+G=b{|7SPy?b}}?%gwI z&g|a3d)2B{GiS~$D=X{h=txaX4G9Txc6K&0GE!7j6c7+dda1q(sDZI0$S;_|;n|He zASc_?#W93qW^#gp^oH*xOdo}wnd&CIt5FD>b6^9D(oX4)opKv29V+Y_XSnLH9!eBs zocNtf!R8#hLeV0|mg9RFmMH9JJoK1-<;N#K7#>3|!py+H82!xa29RSA;1lBd|NsA)GiR2UmxqRi zzI*r1*x2~YnKOcdf~!`o>gec5OG^VPba8RHd-txAlG5(oyX9pSrvil-OM?7@862M7 z0LeFcx;Tb#%uG&jVB_X;P?4W={`7$ZXEro8Hg*jQrHM=o!5;L<}LRvy# zK*Ndm3?Cb3U3DnYW0tn=FiY@waA;9)qvO^UjgA%P+pR<855$x)Ds1FiB+l`ykz-!E z!O>O)rHx#t9@j9aOp?gsZm8^e)h_X4`utRZyDTQ047NdHNi(DOcmf^6;OXk;vd$@? F2>^0?UMK(n diff --git a/docs/html/img12.png b/docs/html/img12.png index ca3ebaf2b71d649267e5814c4dac5c49eb7d021a..ad89ebc9b5deb3504a5caa49b52e2ccbc0e32530 100644 GIT binary patch delta 101 zcmZo6=Y1QQJYD@<);T3K0RTR59W4L= delta 107 zcmbsM8Bk{8c*Y;)1U=+h=7x(`vg&Z=n~CSnZvqMO+TOJaqVNtzo6EW zEpf0@X)#!5&jTs)Yx00{J|7_9E<_QmKu(21JhBg%fP>jhSF?uz+^iVDpW9cQV)nMsVacgT@Jc_v zH>K$~Q8fw4w+6~Q4b08-9TTZns8L?1sbyBXDh8BLtMzpmYi{bGZjS|&OTftI-Tl?9 zGB<{@_?U~*dR)k+vwRBcW1I1o)@u5af-zD$e&Jfa=l=mE-QAmp+NzFeowy}j$8pBf zYtJRP!DuFGh|t=EW>cLcsx$VZZ)iPC3t8ky^dh?gw)qE?&fPoIIy^FE1v=+cEi!$Z zpR--`d{Tm10i_mdL$rJ$+g!SiUE*B&>Y{vo#N8y8(9%g$y9XL_9#AMJ7q~;6lulGT zR3;R;1Jk-J`}?cHfKrnb6l45fJtlSRZf2m~7; zjU0hT(4Yh^#?fl*sC{E(5s<0$X&ii(n#?(?OKvkww*@hDMW6lT+rMa^W&q)1pdH4Sc s-bp^Fuaghz>*Ry_I{Bc!PTmvsKShh)t1Ws13jhEB07*qoM6N<$f|ciIzyJUM literal 808 zcmV+@1K0eCP)+0000mP)t-s|NsA) znVENYcU4tY?(Xh0Gc(N0%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001 zbW%=J06^y0W&i*Jrb$FWR7i>KRnKeGKotHmn`E=eCbR6RJ!r?pL#tq0Z=N>AA5@CE z1rLe`b5IZub_;s)V9;WVtrGhWn4>p?l%fQoO3|Ve*Mf&qgr#`!*0hMWJ+w{|Thi?h zD^(EbcbI(h-kWdUOlIByNf6kXN!llgr z_r^oV%=r^Nnm>PRP6o04r#T@&U7-1|yXyNMYyRI_-am(2eoZ%JZ4hH&DJIz(2U#Ja znKTRWXK#*?KCwRH^pVw|%>oU`D~lf)$hSKJRRt(5ZO)miu~wDoQvCOI*DDeYC>mIX z1TgI=U63fmk!p(-L=m{}If@EW;AgthNO@`sr7CYL@Q4mAycf1TE=2dkhJB@u^hDa3 zL1i|>{AaVIhevn#T`Xe>O*!8S8uvd5G!N297{=Tvy5=HlBo2#`brA>pyp=57>7rP2Bq7%mhiOb9tICuhW-_0eA%H;>97FI~k zR7bq-45w`)s+g@9XrDq}IOR>5VHIfafaDOC!K<|WQ<}eAw_z~3glSw$&e@7X7`W+v zL4PR4*)-@2!Y3UJy$0j%m$<}Nbp)S6OMwgU3$3qK@sN$~F@n=~tr?t4D9au_YcSod z>YpPe-5tYaQ!{~~u-s&Ap@gzt;SZW8MrjV&GdL{tsyy)+B=J_$CGv m=6wl=evs`@dKbIc3O@i+C!Uu>O7X-10000`6pHR49>SU>GzY8C_rkgkp05Q|ti@4C*NI77&Uz0mh3wgCfrn zfXr(F;vN)vrVYrv3mEbYhrsq$Flbi09cDQIldlG1&ZTAT3=C}`Zm18#1fGT`tPRNW z$-N433=A_s+<*=S2fhFXjs|4&1GY2dFfc@b*`FC06dBOufr1@SdA17<3^fb}Y$)<9 z4;VfhK+NYZO53o4p#kAOkS@*ztQRIg+{ZDKb6ZuU0?2<6_koUP=m%*kU_KVWa2RZs z1A`F|Gb};&IWq%;5(Co#WFZR%bbuPZoB`mMF0Q* literal 412 zcmV;N0b~A&P)SV896kK!gFBU;+a#ABbketq%-1QFsaryda8~VFOI$ z0s;MKfE|bzFd^x6XHjSXv4LU-Hh^U78xAmh01Gg)JMchNI>7WVAk8|`KmwEo`#Bfn zKy6fOnHadC0>CikNDw&A4iXSxm<18s!0>?^qJoKVfp-HhI5{EApUg0oje(&6#I#80`DpQlfk}XY zNn7ax#C(Ql4C@6L7$+dRW-W%tZlUnl6wstO6EJiPIRF5Fuq@>wuw2#v0000J0O&47V{6T6H9gf3-ZNMUY3lS}~-ya`}7Nb(v(D}S1bYe;Mkuu5;V{W^kh?;C7$)#EJYk4nU=2CIzzGs!+5lAm z5@BEn=wNW*3t(XAU|{8FU|lh8hL~ zh71OVTo#BeENcf~?f{Aa-CdNnVFg12$feuW&|L}?0fxg&&TUnZ3LxKhPGH~x8Oy*0 zQvnnK0tW^oAZFllU;rAa1D0ThsbE147f6(#hdK(F3Ri{;aNvynQ9yS90M4K*QoTyVKoI`&!zIS7i@k8?8(3P}h&Dcguv%SnkT=jqL4Opqu(NOrtE*CKx1~kE z1v{U?;zY33oyq1dibT2YzU<8I&V0k{%mnZlu(s$%&+p42Y`Iqb!EQ$k8bfJOneZRE zenm=wiSV}wkV-uy*g=7uEay%R_R}0kFpy-4Jy#=}C*fSUa^DOETBYSLBVd z_}oUS+-c8Aynh7m*QzqqzQo=LiIL<$;J%KGcr^_n#Iu?g65Iw?g9ff~_rp1C zou64p{2zUtEmr=xazrw!_AGx#84g3>6q^u*`Jb=aXYk5W5tRX^WMKpy`c! zJVeCPsphA|c*EoBt-?C6sSvO;nle6G@5%U$FI`pB^Ba~_7h~b^1%N|1llN&oj{pDw M07*qoM6N<$f=%?r8UO$Q diff --git a/docs/html/img123.png b/docs/html/img123.png index 8ae7e6e58190234b3da209af2c9c766da4ef7f6f..cb5abc277128690f2853f61b5693bfc6c4477040 100644 GIT binary patch literal 320 zcmeAS@N?(olHy`uVBq!ia0vp^DnKmH!VDy9Cl?(BQU(D&A+G=b{|7SPy?b}}?%gwI z&g|a3d)2B{GiS~$D=X{h=txaX4G9Txc6K&0GE!7j6c7+dda1q(sDZI0$S;_|;n|He zAZMSai(`n!#N>npoE~gRejJm}GWu*}H!xUYVBTGzzEGIj}b~$1^aq2XM3; z4692^2uNYzH2fg#&~ii1!r+R5#0JKjJ9Pwl@3>}4hZ&eO^xR*^W;icd?fJG<9;_3T zt<()ZNHm-&N-$tbYE$Lm(c$5-I^nmKVX}tYBbKV!jIVMfGTd0sePCj^Z>QqZZ)$KI P=o1D{S3j3^P6SU;u*&KpemT2LeEBz<>mJ`515jPA0e-1_lLOs!#zt z5HH{at9EBmXkh3Di`F+BVEDko@BymGfq{iM({O+Uu>M>izQD>45dt}N0s}{az;Sk< z@dXSF8yG%t1D&w}sIHKchhYc90hmu1E4UO$|IB814gw|A2(}xfZZ7EMj2bW?;B+089bFDmDh*4ZNVh=IM0+hdBd-MMBR< zi!TgJ0u0Rm85m}wSh5yuk^+ht8;GkyH6M}=0La`V>GPR%*Z=?k07*qoM6N<$g0rE4 AxBvhE diff --git a/docs/html/img124.png b/docs/html/img124.png index 03e5d0350d226cb15e264056ef036bcc9af17008..7ae488a25758a707f7f71372b19da3c9d4978418 100644 GIT binary patch delta 281 zcmV+!0p|X;0;d9y7k?iF0{{R3?SKmk0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HrAb6V zR49>SV4xmgGXN43kOWE@7*ZH45Paqa28L@49070v4hIm)w0{9Ezzd-cfrY1U$uaO@ zU?>ObY6A&yGMwOZh+tq1Il#a$10=x0@RWg}gMpO;s3HQakx2j~z`$<+6JS5U%#gvr zkjnzqlFik?!2mRLyBgHc+38CsfvoKWI{Yx$kqSVyTn<3P8JG^BIGq96=?qgr1d`_% fIMBU61OWi0eG(jFmvAn300000NkvXXu0mjf!0Bvo delta 296 zcmV+@0oVSg0=5E>7k?lG0{{R4Z>x^v0000jP)t-s|NsA)nVENYcU4tY?(Xi)%*+uH z5vr=Hh=_=0W@Z2Y07OJY-QC?HA|kuHyQY*5oB#j-0d!JMQvg8b*k%9#0Jlj*K~yM_ zwUE6H!Y~kpKMcVrjxs|=$OsfjwCQLW!3_mXlnEjlTI3NtLVqSfP*AW1_5~CQLYG(g z{_i~>jH0vQQ6oi7K?*K*RO36qP>RuL7Y4K}ZEL7j7lQi}w7qrlKxMd`u)<3AfC)UhWw+`YayT9Nvjz ueX%Hud7z77t07F!zi4#_nVsfKKkx$fM;%`KN$U3i0000DW`K~z|U?N^I&x0j9dkRoD`r@;8O;>G zZVA)XSxbicj`y9c_IsOUJSu+$RAJR&Icy2>3S=*MKO^-$6R-MXx>s7a9+sw^zLtka z5-%{>q~&I54IGxLKUimrl80acYlPN;!xIuKkX52H7TE@r!`|g>Ek_FuC|%xx$!Hg2 z(})4VRA(-9-BBwmu#L`4EuIJ@pq6HDi7Fs94?(4jrKb!zSI``Z)SCEcb)tC5D3!x2 z{aDFMTVtfG9GPav$dfSQ(qcf>OswdET73ARH+1MWYnvAtepAnY{9d5-6tMYxxXu-{ zRFCN_4yVNWwPksf$ z2IrBtn-J@qL#%eOhSZ!h}e;6a9uce}U?Bi>QmtqDzsMa_A|4e!`r@Itg*)Tz&2s4@>7Lv|<&4M2 zU$owzHTeG^zu+HKRY7ReP#FG_rs->vCQ(5q2#piQ@UnUFCPa|UA?OZc zHzhmh4)w5s$S%UOR@76=4#Nq;5D^B-!WhB~LI;AoS$a@d!Id$@n{RW2;gI=~tZPfV z(aS(&-y!dN|NGyUKmYsx7oZjzu?*EX7we(O`|}uDKnIL9JQhz5Jq1SgcXL=ccGo=3 z&?K4d7P1=Id1F9g5EXW<(8`-zMtdcOJxg5V4{?(aK1`TQ5R7%$bd4!@vVcM68Q)V3 zJmrLIB!DZND!|P;-Inrmm~f5yxm6*whVyTz5GN|4V3h;Dq(+$KBErfB^N+h5uX0}s zrVB-h?w*VSL4H6d!@ZMM)*M&8tl4Sjk@02~)@64pY1O+Be?pR~cL<;NkE2tqnCo59wTkx zE~>}0@SqbpI$Gq7G+M;FGOuvOQ3PH5O<+vr9VZ{C;|5Vu5g6^f^+x)s$7`E<$kQmV z>gy#Qv(Dpq?OsICwgP6vm)B(|)SD;rjWoQ2`wJgA8-!(aOC3Xbqs-&%8A)&n znQiy=SJbcapO1wV+(L=Qr|MoSmdU60Iwiik&n#>g+5>kE{j7yp*9KBa2YNx|>L?Ys z1Ydkv6&VNAKKzt^+%Dm(U8A1DroDnC9p8K_XBw3UFvs143;zV>G8#p$*G{n02)g~= zpAu4+qAy&sm-~T+gzn;e^Sn00_kHYSx*G0cn$@fnXImEkwbFVZM>xU(_zTU#wQo4? R-u(ao002ovPDHLkV1nmUhj#z~ diff --git a/docs/html/img126.png b/docs/html/img126.png index 8aa2fd479620438432151766fa114d58be561f87..92635fe32936e26448f09765df57b8fc2f6e3199 100644 GIT binary patch delta 284 zcmV+%0ptG90;&R#7k?iF0{{R3pHFGL0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*Hs7XXY zR49>SV4w+LGhkqt0A)Hr=u#lIfG~Lzz!Y->kl+YF*2e)-%zv~2S%?=*9s&{U6%3ly zZig9s7#OM<7}`KWp*{=~cp9ECM1X~6fP?}%7##S3rgnfeMu5rB3=E14C_-!(92jaC z3>Y%NLST*DMQIyWFf@RSkAND_F_Uv!RipyQ5&aAdhrwzc7>t0JfeY-^1ISLr;vt5q i2yeqZi3ptG1r-23^&cVlG>vBf0000{6&>ok~$$ z-7=a<5IPiR2NC@T+NGoC-rPc3=-$BtIrotJyXWy8V1`X~$W^9Xn&R9zxhO#Q#EZ`f zN)Gs;ccAp)j{cS=lihNEMc+GWQ>h%!Xp`%rH%ZA^5m+pkWA|Mp0v>jcd`7v|YiwS& z+AyC^?*OArK!1vLH&g>??uYtCl=O`?{3;Yy8rgjsk^wt}YPJzTP5T;UEa?&E%QhAO zFT^oT%_)+=iikqSVZLNUu!3jy00Yzom7-h+1&zXOWb#Crl*@0OQ_oa&;KUV;7brjA z-DA&Wef6=P?Qq%KYOfi0kNR?*Hbj$#SUrUL8f;Z-xK&>q0%>1<^I$n#m?9J85pW>I z8s$L^@QoTw8K@k3Om)z-XjyKH_6|>-lRbn3;sBrUhV;ra!mwezza0Wcuzyifg(9D3O16QM{CHlpI|>US d^SV4w|Psx-hVuE}&2!C?idVFN3SW$0#@02THqt#V*sD1QaBnHf45EFi+{ix^lw zF)%kkcr2F~I0C?|S|C2jz~KPZ477U#Sf?nEIK#jTRi41kz;Fn};<^A9_hDd|6`oOG zFDS{t&;}A`1R4B;A%cO;;u7lvu%;OxA}|5yMp2+MSh)+>4uHiYz~VsLc@6-@8Tbu2 z8W7@)K=tts3}_h)41Ns!#t3sbHZZU}VF2695X%V`2iwcgq1*us0-!s$GuWhpMGix} z9;yIxt^~?fQqlGPdAw#UQ}U;u_pO09c-dAf~YJ5q~O?%>=q0M85$|5C{Yb zA=49pB;5P9lwy`S!b#rg>FImt-BVCB29tSoaW2dLwkW_)s}ELS1d*O>4L{#1ov;j6 z9c&Ryt3LUV!wBMz`wu-P8I+nJHsinUQQ%W;1Z|Xb~4xOL6_)EMKcz{E$#?HU!jPuyh iw;dgnt@IoI4ZZ?A+G=b|9|)H-QBx)&zw24 zd-v{Dt5(gNIkT*+tfQkNH8nLPB*fX-*~rL9QBhGqK%ke;BoU~Qu_VYZn8D%MjWi%9 z)6>N^zR$rElGbJQgB;_;@zGZmT$h==emnH^3fvX>y&hzTrW0<&3@!XV9g@%VlZyH=*Jm6;CcKp3mV~*WD z_8!KXojh^;4Rg}k!pzv5*>Wc=%I5jZazoG7t06NU_?hSp%!yPVxMML>5k Nc)I$ztaD0e0sutOU(x^o diff --git a/docs/html/img13.png b/docs/html/img13.png index e55068840828071160907831b76f8652469bd1df..a0b3f9af873e6bed9313a078d4e09e49c8cc5d2e 100644 GIT binary patch literal 2914 zcmbVM2T+q+77mLAK?LDJq#F@Yq&#{62~q-tE<{nP2mz!TA0m_wC!+*?F_~&Yg4TeCM3+J9A5_n~R;esJti$ z1QJKs+qi>3LNLKn5)l@73debm1g6c+2?+-T0|~IRvH%poTUxRPtbtg7lam9a08DFZ zAP3MBOfmpa0iX$h2qql>m;kT@ER)HSfFuY6{Dwp>EdjkC&=Ro3WC9=nM5hZvn5$Ik zDvd^^0#hgy9iWrRz<{KrpfDAn#>N6EDZmDujzS4)lV@XNX*2+d6tLwCK_CKJJv{+` zN-PiyfdJo_%x~l4g1Rh0j(}29pcEw#!Vm=M0Rp{9012lG-xhQv6yxsV0XjK591H@9 zIv{K;k#V_;d1Bs-kFvMhJw%L6F5`EpD%$KU8*wm1?bZMT0LfH8bB9~fZKvBEZ#QAC zMM1A#of!{~s$o8s+=#*C1`l*jcq`03ieB;__!e07J$SU7{ZM<%e%CmMSW(iD=Kek^ zCR4{*BI2rUxmd0SH_@dzl&efqvLjL^A zvxizfWz61kbPZWl4#%KT^%lsr0?4$yP2~cv95w6 z{?C!C!HFicq~WFG=AmW7LKo9j(NohG+Of*MlLDjZNQ8FG7rwiva6o7Gu!8PXyPUe5 zuR$@AWF$r;EU2RK?$Sgf%-uRemedd6Bq`%Zybzbrg0KaP_mmuV(Q6334pT#C^umSL zkELeb)s}zaipUL$=>_2&CJz_kcg=hJ_0+!7ZUg600|}+t#Peg&`fS}!cNwB~Vle$x z%s)!+D~KNTkKc7FCD4ah8!AI2k5foZ{K+8cT1{U8S!c7_Q#R}jQHgR?2FB(!l{9EanU!nCagLAFeTzZ!mg_;qm)s7T=n@jcQeN&(B&DWv5p)o%0#WpG?F+Nriy)QM7v+5!hO|>C47Y`oCX@SCK!qDQD$1yS5|E#7r*v=(Y5QoEr@v zAFQd`_YMmGTi|?EEa43$GDHq-c#?FdF3#lbHs=gAakSjbj;;Z5ab7l;$MIU#ZhfHh zd@*C~KXfQ|Hlrr$l2U3h!>7?>B?8x>^ZiG5tnU%RS)C+F_Nf1BOC`3U8BfxUIm3JT zsG=P>D+}4{umTkaOO^E(Ol1+txvNp0>;B8wplJWQ13l^w zp+7&B>v?+_cg=6wPQ_cLj^>mSC+;TVc#j1mUhC zclN#c#CEm!hh8v?ba>|_T#lj~)Fik&OyX?!Hxj&pwo&ro3Res_3i`Tnw%rBKwRVGUVP6<{@b%9)%tsc9wXi z-Q3^dONHynmn zY4cy#(kJ(VXBY*BqG1iy!xc`m6PWN^IiGznR#DoPWe9@Rxw5J^#p~SbsCz*gccjNt zLXgrYQD3b=>^>Ggw13cVwDNhUqOTM*=j(khig%2Z;$E$AdzFL6uXFdGGwhm&g-0-f z<-SL7#xYJ|!o_p9tO8=$(RFzNQS=jiGI#XlWuAKjl0k~%+Ao^VpH4}{{~9RHo`}39 zqc^#+w`oZK1D1+$NLo&eKd7(z$IY^bWa*X2FD|@-)XMXrnqh|hK=jb9jagWBr2&1vR@ss@e+ylCW4?vPWp%u%3JEs${vJY-o0BggKc@D~D^4puWy zmHN8;2FWDQTnHVL3b;0R72hqHG(#Mm%hd{#%D0l!UGL3y7@yMV#n!@ZHh2x$J;N`g zPm?Uwcx*~vI7NBrr<&AEPzn5 zy>(K;;)Lmli$(<6_jrFnrK$f=yB$qcm2BQXSeq3y<*g=!JK?Vx?e;7gFRsg;8)Nr*Q(qk1Kg~G%fCD=VuGt5p3h0 zZYJM=C+gTI+CS~DJd}3D#fQ|98h1=^XiaL*t-(dTl@LPNs%j=7-&`C`5Q_U8PlQOC=I)s;_QFJhCv0>Hj@!o8{m5 zC>ZG7T1%(hWCICtSQr9>t}m#GI-_F7=;T@G7`9lMz4I*laqkgu7n^dc^Edtu0)oPU literal 3167 zcmb7Gc{J2t{~whiSw>Q*WGS+ZrLv0}Teh-f8B#>VkR@Xq6UkCBglvP7EE6+`A!=+1 zS;oH1#AKj0My$X z&;T@&l7LwU2WdbWi{${peSH8304*gYF&F^A0GQ3qKpy~L0U!z3W-urk8XO`33V^{J zYGA?Jn=`-(aBu+Vxw!}gkedr^^z{vaK%BTSFnD?zKmdptD3rnBn*OJ?0Kgy0zHfif zKnu{)%;_UI8L+vWz5}p|#U=qsAP~S=+@Q~mr<}cTh1y!%fegP+dV@fGR_0J6`)~}s zfDcvtR`^4i{>Bo4GUuVV2+LkltM}QI*MC{nxdK$p$lh}_G~>ypZzE8jp5*Ew-%ET3 zRX;k`SO4y*{+ax{`H~DLRhRYyx=*LlW&7fFg`Xfk1WsN7H(yMdXRju|W(2G%W3ya- z-{cKw2tiebSM%sWj3ryaU%^}#&7R!eqEI+@p|EL z+vA^)C>j-ysTD7RG1L6A9uXH>rxwG%RG+G!+i@c;HLkL0VcwUzggYsD$(|jZDSJ0W zRF*pmz`k{uDJw{$D1MW2l69u0K3oBi`&M{otDiDlndt{E`Pr0ScQv%Vnzb+zsCmX6_+Y+Xm`UY!(fK|Dk$YisHF>o+Qe zgpc9h@eMP%o20aXqF_m=U!`ci|8Sa~NLB2)^Qb^_$X5UFMlRZJ8JB05n+I2!I>niE z$YI(9L0lwes>et&j^{P9@$8Pvm0v=#e7f#rJN%)nmHa1NVD7A63KpMyi!4uP9yRE( zl8if%baY!DgYG$HVyRjCW_d6MehXZH#t3{a39R*uRO{Jb77XHs5<$EL;BQJy)*mhYxW*$bL66-~OCY`$2l$NC6GJGtnJ;rZ zaVOTGZf{@KDl0lnWN#BHij@`1Z3IT;_AOT|8QUiBkzGB*uhYOUj?Kn}}c zFHsDBy+tXw5S96R*k*lX;@Omd(KcIP}!}hcrs?6iY05!ys49JtKIay_K;4Ht}C^&_m)1=8PmE0*XX@_ zzCs9xV^%=ibuE6@H5Cl3Ew{NXfgbc6EVhG3m_-JB!C7T}U=~}CMOG{Do{Bn)lf72b zYDgVPqe*6~T9gJ-x6 zKxq$sLyy*b$+B7LO@vB&H}^3~ z>Vh~yfh@Ggh$A=6*(V7P36EvBw_VL)CQneui%_tuSR8%{4T(EZQDK5iaKc_Glq$r2 zf5o0}cBe|iNh~;ztxVVw+#XJ{1|F7OGr6mMLeINOIPLZd>TlM+Ho}wDd$pA}wH^9t zowd3qb~ONA+cI_F@Bx|LeybN~r*tQ^3RY}}ywrVSj?C@&)aoOvKSJ)ec`Sp}c9+e?ihjwvf9}D{HS$g!+uHJ428mbwSFClp61odfMdDpg8QDVI zcI9GSM9yaoF0+dV){h8i&vFCS$2|SxJa<8+C&U|U4$J;FXf=?T(?aUB1e;tJ2RE`yA1GwYojd8d}q%uEKu!3SD99*sqkAqbn^keK^D&v!>6lGklySZ{vsVnrI$9yN_$U2$Oqn>bwd zo%YstKOzV1T!95Td@|T$q;>wIs8FX#1f>>5%e9{oeHMyT z`+^`13@naYXce;qP+9WoHF~Og5v{+ooIA9Ps7xCiBVEk-IQU0Q1bTIuzfB?%SS$P- z6b_5S&8@xCc{lAUn<;i}$e$6AdrfnhPr1TmjcVm2(mU>-euqJ^SK0`??qK&=r4L^r zAxW0dWRh4H{4C23hbGRir{iPcUk^sHaY+A#a7aT!NN)Vb&QRXx6=>g!*0MXh0s~X% z%K2Lq#|rMI-jmgVk<*xVZA!kvFuJV9A)=&UXzW{}krm@=Vi_inL4It@*6n z5@RbsO?ojCblW^cCPSy|bg9ZY`%xlUkM|YrxT(FJ+nk8qVTnPa?f>MlK1JUm^1Ag0 zq4UocwX#-=N_?hPf*eDSCVlWSyeKOabad0e{9z28&tG22TK{guzN$H0$Y|HzI((*9 z=V<4D>k|~nx12pR<4e_Cj?HCyR0$=GU?sC74sa!1&o8~McPNNvR(B4EWna2F5ELYG zEc@V^F)deVNGtt(>0+a+8J31Gwz7Zpu<@wjR>@xxdM!mW87S6_P|;C2yl2^>2_BXQ zyM3!aS4Gtm(=C()>KXSAwD^b#9{n`;aB@pH@vyIjtrB~JLoWDpK#`j)_g9SD2hH(a z$@noJNm=A^EtWGEJ%jC^xbYkrd~rU*G14dcTb8&uJ>%afb3{g%=X`MEra6Dg#(z?& z|GyMQkG+_dE4lmRY? zyBqzXR0?w;1xd3$^8m@UcPClH+l73v$pWP0l1jT*v#5)ls}yg$!%m$_h^F5Mt4$3o zvhY4j#;9TSp775(3!!z#Yv`DOa@VrU9_}BRp%N(W&HKr-e4gye;BMK>hTCUM+AiTX zY91&Wq-js}kxo%$aPgJ4_Cv&Tyzc0*WeKYT+#CF6d}im5`cNwAV7^+x+HIFx6r!kD z%IAl!^%TcP`di%#-6O>Go@;EAdC{n8{i*uEsQ2y57yqw{tysnK$%LF4R*(&^rX{3A+BE zRTJfIw#L0J+;^AW)b%^2+2~se04C1dc?Ys=sZ4WnJH}8dz)@iuC8&pX(h= zl_F4KVxeZVK!X9Wn&5?1kc80Tu#Rh#cP$ObYi4;k31(UE?CPfSo{edN#B8+9ey^({ zHlsusd;3@|w>MRWx*JtgG2(nBp1u|F=0*{shamVWeC5ViNmyVnQEmksfQo8~3EBz( kei>0=sf8KyiUTbVGS{!q1fVZ)e%T;%V{0hx!u7a+0lNEiA^-pY diff --git a/docs/html/img130.png b/docs/html/img130.png index ae2386e3facd4cfc362d95639b6267d781020766..0aa67790651afd690f133b61000bbb3f18fdb275 100644 GIT binary patch delta 484 zcmVMGTsQ`t`=0KKC);R~DEanv;k~aZExm5#JQxG~qfPVwZVP0i`-BPQ?I9vnM ziOgZ`!eL4TE>o}>!@5HO%ww-$U}?`{m=&H;GHnA$Ai4>n3@B2-vAk>%eq(x}ZVB~a z@KwlTv$(|ijNvFq_A*2qB=R7*N1+NsCrc<01faPlpo8H#!z@FPQVirRzC+7in ztU5uS>HUG6j5%g9EK9$Zu$>{6fhQ749OzM-RPJq63SBsLq5=m776oPo0|q7#6A1uC z6!?vCq%Ane=l}vN;%p%C1}MjmfFTSFrohk-!6MEKiWaD|SocjJXwE1Y1tS*-QUeGK aE@J?dmvw&GgDp@10000MCU4WWS9T1=Z#Jma&tZ;z^2sy?La3+TWk{;ynWI(7n0K^V_>{$$q1rK0qn19ZkftjOlpOKT{f&thZZdL|?2RtA-ggGGh?6~lO8>k5E9!~yg{0?Y# zVFG6S{se>DM5q}BD8K-P=SjRq)cAnL9RH#V*j4}1#bFFLrZJ2MA)NaL3~c(d82%so zZ`(f!Bp?IHjx0hKe=6|L>{lbsm>UNe4gu5Zw+9TC41eiJ#_;ofU<|lBi=i98F+hb% zAW!l1`fp*VO<)#ad%$1_@#QD5rzSH@Wn-vi2*PEI(k5iTGyi9h{BQpum4Qou!5%rV zo-wQ!;5^ynfDmESR{Fqz2F?J%A#_2I>p&6;P!2neNEih}0001(WLsXGW-z`00000< LMNUMnLIPldSvJ^- diff --git a/docs/html/img131.png b/docs/html/img131.png index af2771c5f2a9f1b76497062c2174713cb2633081..9aacb9c08713ca7fec792e3d3342c000b129ace3 100644 GIT binary patch literal 530 zcmV+t0`2{YP)FX-ycmU>LcC6OFv+%n%K^f-Y5YKa(>8$g?@$1Xb1p4wXW&>~wg`s-9G9W?g&bh;RmfwrxWxL5;V4j`7ixcUuR2A27sa7C zxE5L`b#itp2pxn%aMCTa1Pl%iqR^iZagd^=UM@|0t+o{kI_R_9z0dpH`*nAK4?=qs z2~357fP<26B}JD+L8I=b$W02V0UD5(4MsecFekKrdcc7mRoKps*&YE@+KknxuNXj` zH|t~=4$u_rJ<*xy3tDWOl3|#qp1{_eE-cHOGUd4k^~0#KHbWXB1A-2HqyZ>sLv9EM z#G!E!yE6CEUc+HUYa3W+`@>?OG`L7V!jlwc=`=poNDL)IvMf)bdNowZR$0b9uOXgL zm-OkClUc2$oLP#$2dO^tr=t3|PlmjgeSj0bD(4fX`%st^fxif1;LTlbY|fDvgtEuA zSo3J5mv)KwmM2ahb*Pfr&CUwoTwo0mTfapPJ3;^wRONj+QQUUM1E7kG*TSOfi#O~m zoXNywt!>EMamQPzAh>{4T227k?iF0{{R3S&IDy0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*Hz)3_w zR5*=eU>E?v=73jP9YXOY;8PTNhA69gNKnOI!NAg<#lX3=tbg4z8>gyJ9|m8AJci_6 zg}4Ns00st*4j^bnR~68~@SI^5L%?>1Tn0V|Btu+7fdKBV&n!X=+kq5A2ZJ92E>&z7 zTpuuec3^qHaE+mZg@J+l3=kYew~@OjHv;xD2kNONu3V$FrBb(|5BDIqWHatk+ z=HY~}b_6k@;d zrA;A$HvviGPzM|dc%_+%G6WJ1{GS%E*ru@?6rN)>5G!Y#kgz@>A@jUB!zQO%i5k&Q z4nmBwJm)3T8n4!*2`1g(Gke$cnz`*fpF*yyCVPZ@!h+`1o6XN>+|NogYXO@?jhlYl} zd-u-R*!awuGlGJGt5&V*=;%mGO9Lu&adEkO_pXwX((c{62JW`%-V7Q4g+mu@O1TaS?83{1OUK-RL=ka diff --git a/docs/html/img134.png b/docs/html/img134.png index 69fa8cc71517b3ae30beee0dc4c9c72c2e81369f..263977f835837d161fe5cb9b0334c9312347474b 100644 GIT binary patch delta 463 zcmV;=0WkiE1mOda9De}m^6YE?001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCruYn4FF-UdhD&iS z0Bc-jfWyunFzLv^AOxZ#5E>b{3xEV`7cPxZoq-GtqChIT2_jhDz`)X;57fiDLjhv{ z(z132j^$;GaOmW?3=v}uIl$nnkOyS-LTya$RfuBXNC?Cu^L0CApBfS>_c zBm*P@yNLh* delta 502 zcmVHh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchC9)5ppAbU|%YT4B5G`%Y4+OUg7Au6b zHhzG`Afyt+dF&>ekcVij^sqDc-1iJS7l>iv5}Ar%A##|6U|a48w1iP|d!SoobYOwZ zor!g(!Qjhhk>Y`&fxWr~C+)`Vt^#h&21*V2Dg@u^G#%axknIS@8{dyO9W;^U^2AO9 zPyEj0pPK{sR(}+wRXs^)KU0^aOTTc^dEiY60}CS#uG@MXz+Z-y{Hvz;7?wC?S`SVG zNUhT{C7mlgr$UBw>QvTGW2bGYvh5~|%C1pA6IIoreX%N~2KL}fmRB)hsAMh_F97tj z>;EliZi*DMZpFSUYz=A9H^--R^HMwmEg_8?ukSh*bZ_y_pVUpw#XIo8#hJ3{wI)i~ z;4B}F`oV{1!Y!%tLzyEzHL{6MpX@2e6OXutQ*?MxAq>@XFvs1~JhEAu+`&DaB3iW^ s9VU;SnBrOJeLZv-saG~T=pS>#C+Hhalmg{FlK=n!07*qoM6N<$f}6AC`v3p{ diff --git a/docs/html/img135.png b/docs/html/img135.png index 0d2507d5da08f416fab71f7803c8dc48cc221bd8..fe6f7a062a8d639f72063f1cd23010b4ba8be7d9 100644 GIT binary patch delta 494 zcmVF5t0`p?37^4m**%oj);8n&)lwpx)Ac_rGFF*vCCVya67Yk!(;x(=ZOgb_! z2!R>Q9oXI20i`Wkh%haXfk6~(*eU~r)U3#A2IltZAe`~K2`pr_7$MEMw5*+>t2|2q zmuV~=Aj3L9Ab^3*;=mjRUj<$V5QeziqZuL1kld>f$7*qieE|;BSa%@X!^&O2z;K*_ zrvZpt!J!)6gn#U-fb9%9KsB5P7#LhbfdIp_mB^+s@Eb6&2r=-d0C7eGNFZtwN+5j( zh9la~et|e{&lw;9dc_YY@PHv+6^L~b9N>TqWbsM3z|6qFT!6>? z-I!nlUI%faI7EO+iJ`8tj=_LQfoJ~*h&a${Zk7ZG29TS*1F$#_ulYncka*1-fKFl* zK=8SN*crRJCYa;yb3fn)deQ*Gzre`M#K3dr5Rzg6RJ|+;5So#AXAKe1@Bx*NCE}zR z7l7|xtI0FFfgpdch|u`m=oXb9NG08=;NXTlelX%Jw5-5Y4a zH~=sH>@dUtmfS>91|t$MH3|?`L>Mqbs1k-QsDLnbb$=01+DQSQX^`~6zk%U5m?4Vf zME;)tD;O>{2`~tLYS7vQmTA7P0*UW)KC2{dx=x`#TbnxF3jW5C^64BZ%}G1NkQC<-#}ladlB^Dr=+U;x^|bYMRN*8#o{2{5NIfuup% zZZgAEHd3I*AWYNXu^@x+D%$~I$)%yo;PgXRS|(8>kU n0Q&_>bdQ3e0*EVWhyxn{|LV&&1@zjv00000NkvXXu0mjfcuoA6 diff --git a/docs/html/img136.png b/docs/html/img136.png index f659c90c4a84c34f67d4316091e38ae9a7bea1cd..6d6ad4dc85cb385e0bb6dad7cd0135161120827a 100644 GIT binary patch delta 444 zcmV;t0Ym=91jz%C7k?cH00000?%DGm00002bW%=J0RLN&BDDYj0fI?HK~z|U?Ur4w z#2^rbS3)h+LM>nc3s@KpSik}g*T7i70v52qr9giuaLcA7%}qEj!)`dkx5EJYvHwAz zw*i_oDEld=G~xw}nj*}V5;-9cGtUqGhjy5}mXK2#{!QxTiGRBc(?F>K)HjLYiMtGQ zOQ{*t#RQxo7u0hIF18?HreK=fLc-d0z=V*@6lXP3DuB2O>_Y!pYB!O)xoUAMEGh<< z(G=WQyK}qw=vo+E9%BW&rBt}-LW$?HT!fZ}^GDV|Acj+0-n%8)M%*u&f;3YyUR}r9 z$=6Bw+D$wJd4Foldv}<-ju^eAOqJ~TQ4dNs#S|*sIP0!ioPI(umPo5|cV_qQN$WV8 zE0=WZ>A|D7QgL=HM??(1Ek&c-H3tuyEoygkg%V+zApK#La~j*y0!NU0umsb6{==<_ zbcLleH*ERobsFnxyZAzqb!vp#@Wt#?N mKMl%$8kGGsDEnzp_R}v$P2P=if_w`A0000=Hx1H}Z87k?fE0{{R4$Pe?$0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*I!%0Lz zR7i>KRliHaKoowtUZo|rQN*po^|UI~(zv)95cdw1bdpnpQlE_!JabBSrvLYImk9Cz>Kd*6GH3-15|u-34Gs&kyD4{<;M0*Yk- zkgy}?`@6>)uxt$+6aN^6p={0FkGK+<7XdX(g#$nm#Y*FcYdU2JY-Ls=^~{*cMz2>( z4hurGE9Y|CU4P6+@C-v|)T$TM&ue)C8RFP_D=osT@e~XpK~r$|@f)2!kYq~PKW>L2 z^&nH^iIfs}Z^>#+WmjDXL@5Y;Et~V0$S}Z{z(6V{A&^!aTb0dE`zkq2EW3Hty3%HM zlpdH8^z>RNJK#`TDR-|Wck4jV6DiY+$ni1ONSO%aiGQf<1T1f=U>Zrzct5~Gtfm;S z98J8$je~6QT!*67#Mjp0>g|i|TI8Mxq4;$PubU_Qs}Z5O9vCpqEtvIn+k_Fim=2`PF=i9rr#6 zTP?UdbuxSfzf(kD%M@>}IF+|@^lglXNof4zZ(!sJHZrtt-E`8ZgYZ0q00000NkvXX Hu0mjfqT2yk diff --git a/docs/html/img138.png b/docs/html/img138.png index 3df4bd77545b396fa90496a94c5ac61a0b34bf41..bf7ff88aa433630a0fcd6b2c45acf62242c7b22e 100644 GIT binary patch delta 229 zcmV`~0{{R32!F!W0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*Ha!Eu% zR0x@4U?2rBZ!|#W`a!4%5NZ~fWW504Z3mMa4It8^>@yHAU|#Fnp}@eva*6E$2s1DO zIShOSoC`phAr_?2QGvSvgc&+Oyf_Aa6A)%N#scK|FvPKgFoO^~kjIr)n+C!RM<;=l fIx!f4F;F1@^oklR9m#W&00000NkvXXu0mjf-)2@Z delta 262 zcmV+h0r~#)0hI!f7k>@}0{{R4v?L+s0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*HlSxED zR0x@4U|?Y2+W;gO-hE(TxBy}>cr!o&5171vjfDXL7BDbyFn=)cevoZYSipb*85DptyEL}|2NrF-+82FSbf7|RIOq*6!GFS?E*b@eqJ>zk7TTeM zRdMkgERMyci$l6Obf}8rm=5CLR8MgAeP1rg<&J9%pW@;llJCoV@0ah(%S#@>fBiwF z)b8q!gEKrU%RF$F2QKo!H+kS09(d(n!98|rc%5oZRn4R@F=f?Yvx6_3h)0;p$HB4= zYu~-8_#xssB!7I2gRw@A?rF|PBc5@XkAtza)9PY#X?i+6*!1+kTpUbG`|i#bgXprM z7iaI|;0hi)_GzI(sk34HcM5ljZg8s}8nPA}=0G$hcC(jHR-ibg3lAQ5zzn;-JJ|HY zYk4T%s$c##b53 zgfDo0Lo3?%`+w3>4Q4B5JM8_za+ZI+T>E5Zs?*h6MN{r!`RG_^sQvgp^$17;_*Iw#4TH}? z9(1^b-wBBlEy|(ir2kl*67fYS-B>8$W~+2Et$BuY#GR=DoahSQu>tNw%LgzPg{xgj z%)lwftC1tRXBZvaCc0g+%Sv1LTxOczauUF#AAbZJ6CN~0D;5bQ>;i)S5K{J~C4k{4 zC`No#7ro_a&I=(dB;LaFusM^&a7p86&Lc+9oS(+FmUi_m`pr3gI5C{FgZ_FxDGRa_ zz{^Rhi%DwO0c<9P$xvdXMSFD)c$0&LbsjjjdvB*JJn-MvFR8bOgB?GRWdHyG07*qo JLHh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCHV{5I?`zPTbhFB^I_m!pG7f5r2Wj097iXh=GMApdtpAz<&rrGGd^DRuoo*FiW>e z8A|yGLSW~1UTDp;W zmbYZEP{+n#et-K^@=5w7E{FoIi`U!R019)u<3XWN^mi<=FP~|fupd!G z1}WtGXh4<-kJ-EKXvLz=i@)*$K1d6txu$t0Hi3>!0+{54Ut z1i2h)GWq{Oz7dZxRSMu#nvNvGo@=AAQ)FSPo0n`>*`*#SrDYQ5)VK z#xnaZd=9SM;w>xpnl+9YUj$ksuuXG$R{*2MSASQJY8A62Q{BFT%ZPsMqS%~$-ka{) zi!Ei1PD*A_?X5{?w?e zo7NXNDdk1Ax)W3IR(rC~k*{s3lVrnQn;{>T6T002ovPDHLkV1i51i*^72 diff --git a/docs/html/img14.png b/docs/html/img14.png index c2806ce03bdf9f17f0562b81be3197aceac97780..2e781c9efc3b82ca0c4658ae12ad9180967744ea 100644 GIT binary patch delta 565 zcmV-50?Pe^1;zxB9De{}(;J%r001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCbbtp&`)XChNrYM-=PzRxRd3ooY`^(LH0qRw+dj0!KX1p9luhy6F(1$Fq z4zd1&IPE@|UR|ENAItDElFLEOp9@;zI;hcJ$xr4jad(25v-CR|P5G?-w&zW8zH`ML zB+eA`It8$L0e?1nf*ZHaTpdbD%?OKD77`dns&5Tg*&8DRjR7Flzm3_T9De~7)GG}D001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCyI719fu<4q03RrHG4!Ab*w$LKpY9xM$MALQq7%;pM&WUtV(W?tuAlR_~~bAnKh^+Y795 z`k2A6*!y$D*y_3x{u9iAK%%@_h})uyK~)UhR>x(Hmj zhSa2nSxzru1Al)61oy0LzZ|m}FVrkY1fdO2&^qmj(PD+uT%M;EO7UO&NBmAyrWf9< zrluD(KR-(cuYICRK%wA&EkEBr)P${C&;WdU9X}bzeQX{|ZoMwiQ^ZY;dkq>N`ue1C zQySj{A+4FoJ71+5?UZo3CPL`twkx%qBTC(qx#PabpMRP8*m&Ff8QXvSV_0wx7+jyj zO^#7H*GykA z>)YK$sB2J^h!v!-VZLk}5jPx6UO`r;M1& M07*qoM6N<$g15CNkN^Mx diff --git a/docs/html/img140.png b/docs/html/img140.png index d3d1573f6c148aed7e57479b5406f9dafa8692fa..e84684c824ac17ec354a8426b20c5dbc1f2cf65e 100644 GIT binary patch delta 192 zcmcc4c%E^Bcs(BrGXn#|g)f0EK*}J%C&cyt|NlVdyLa#I-o1O~%$eQ0cduHtYUa$D zWo2a@9UZBusUaaD&d$z8Mn;N?iUI-xNiWrR0W~m|1o;IsI6S+N2ITm9x;Tb#%uG&L zz*3;6oBjO^+r~-NqK||sm>SkJyye-+Q^Til@H~$!k7b<#+iB*uY#v!11zGMHEfVu~ sFht&AT_Y~h=f|*VhNOguM8hP8nL+$KTb**^fhIF}y85}Sb4q9e03l#SWB>pF delta 200 zcmX@lc%5;Acs(x*GXn#oV!H4i1_lO$0G|-o|NsBboH?_+ygW2C^xeC6#>U2H&YTex z6kN4xRYylhT3Q-Vp^J;l-Me>{l$3Vw-YqYyI29igP)F5N0`p>QqSnGB7@-a(*%oj)V3A~b0Hz)gV^HK7 zFvVxUdI2K9GyzGLa{-8iNik^RHL3?pIx;W_ff>vl$Zq2<0FfLG5S~Q~5hevPFo=Q; zT4jKcVrkDeV9>}+>)W9K;#w_6a_rKwb_R~+Ws7i`#L@vWr~?E77#MsN@)#I4v2S1m z8|2Xpavn&km4P9-S0RoexJRK1he@mu%VFR-!z>1d7r_d#AWn1>vQ)r!h8z$v2WWdJ z5Cou`v=Z4Q79oc13=Fxl3LPL`)FhNZ`OMG(B35IVWXQk_3UP>|_M8EN00!0v44)m? z74!m*vA`Y04U#$vP9C2PfW&hQ-|;xG9RSg+9f%NTIl%g$z~6yeL5Lm9k7z~;@dd0G zCU72LKY(Ep%OPus5y+9ZEd5#nN9Z($qfn0_MILtn^RWQ#ZB%Iwu6^(*XFbZf60BAX5C6uorUH||9 M07*qoM6N<$f^Go9`2YX_ literal 583 zcmV-N0=WH&P)KRJ}^WP!#@h+a_sib7Q68U@-;<6~sJ3HaAVh&B2O` zllTawR0pR%LVW-+IEZ6)cE}3|;@~C(-4w<9(>7_fwW1aWKgd1z%RTqYIp>~SAOZ#Q z7H9>Z!#9yjAuMM48vltf=;Lbk}fk&w};Q45LL+x4aX^9U9xQrrr+_>nT{f~NS@YorZpzk zLYk4g$?0#UF*3|V(*XzMHqfr4Cc8;_??idgJTWDQ>dQjdDjufIbhXQ?Rc$Motpw05 z$tvY1JrWBXq+Hmx1;6f=n*s8moOzC6bVo1GWM^`Q(%gZ>|fvh#gvwjy$+|^dBKRKIH!K@|S7JA1eHgAIgO3M(XPxr$)GW-mxML1Y67`8??(zWEXbO4y1oIA$1C`hX% z%k<-cm;87u-G93gvqj;b*eL*GlF`HDUH9V&az72}hOsR6*qH^+$?T8H8D-wDY}|T; z9$s62ji&+bwdPTL=87gzTsb1EKm4;A%dRW3BIN9lL1(kLZI>%~ufv;6S80~BpBr;c ztQLLILSO_Ct<)h~yJ9K(=C7==W2@D94J^ZQdw8pQ)qgMpUi@X` ze3hY-UOPt*;&dIbArg2hRnRLMCTRK&n1&;bn7JrMYvMmK)irB>jHZ_mIS?|cg6<`) n^-ow!;QIbSh8SXqvyT(d1cGMm2Z}ua00006OY7k?lG0{{R4=(eS&0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*JT1iAf zR7i>KRnKb^K^T2I`yn7!MercxKX9c`EG@)uW;e+O6C14u(Y`PJ#MSYrGJQZsy-;{Q6^Y|YBj)fCiO}cw_1|ju}RblI*q=Y@~vqmT;2rQnm6h@ zE-RM2iYYw2QVaHQ0<5$t4(R_0XF!)JC&n0AOI38pLQUuB{DG@#F{e3~e}NJx^&R6X z(VUL!B0QB>!{$oLs?`MTs}X`*XxPlTjgFEPQr~(utA8+2^iw{Kz`&Y}80V&nfzwaN zYo+3-Md2A*EIvbCNZM$7Y`Wl!n3UP|ffWow99nCfHeR~SpTix{@FeXS{#Mi;|C-)v z_32$I-h=$Zn{+CqA{A+MGJSQlk5L~pfzS_jHMg6(p(BoYMUH?s+H^Jp^aSdezSF^#xECx_!|GGM=|p(HN1ud*lbk*P zJ2)0cvhWdKoW5;AvrAdZ^1JX5u8)QIhh6ACkxE!dKC#!*sdXjuvGQ$d)7aYYVtd(J zqyL^c3hMlrR7{MQL%l325uVo82}TS)JFV*({vmt^Eh}~Y+Io7G00000NkvXXu0mjf DiGNjg diff --git a/docs/html/img143.png b/docs/html/img143.png index 151cb99deed48473e446259a5e0633c0a22077e2..474620ca0418843a4e3544dd9bb510ededda4978 100644 GIT binary patch literal 494 zcmVK?(8H*Svf|&wmu?H|PFmE(KQpQxkz}x`mU4yeM zK!hKJ{QyL;&N;xq(2B*P77#HD%w)X)rZ|8qwXvuK%Wj7#X@INbQ2?Z> zfNt$TQ^~HN7m&*WG?Il?fPsOnfgz58--Pu6!)J$MEU32oJ8&y(S7Y!nuwW8k&; z0}nXTOn|;&U;<(WCI<$FB@7Hs3n&-@0000mP)t-s|NsA) znVENYcU4tY?(Xh0Gc(N0%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001 zbW%=J06^y0W&i*IiAh93R5*?0QNK&WKp1_wCTU9BG&ov>1d2G^4yhY15y$6w7pI*N^@(Z43BArY>;J|VZ&09Ots5xxnngG0507q#Hs$JT6Q?e9`tI|qv! z(CU2<1Mbe4=k~^rNQ;tf;IV1}Cu#4R`nDQ$revmBr7%UTq&fc`J^f!(Z diff --git a/docs/html/img144.png b/docs/html/img144.png index 18cdc9576d9ad2f63c7000b0d840983cc72eba54..b08a5052ea21d6478516bc8cf5644a6ad67360f8 100644 GIT binary patch delta 242 zcmV`~0{{R3<4Aed0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*He@R3^ zR0x@4U?2rBZ!|#W`hiJ4C~p>+jD_;HgUJps=~4EXK_fFE<7;&jki&9`?E%9k_6-a| zV9f=b3m9GmE3jSw@f;Pn3m9@`6*w9|yf_Aa6Ltl?0G@}0{{R4UlW?;0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*Hib+I4 zR0x@4U|?Y2D*zGcBFfbedQUVMN z4Ge4^3~u}k4BX5Nr@4R>yBsgK1EvmM?F-0UDKM!7CX;@?Ww`kNgU}|BMLY_e3mA&! zFK~j)XZY>FevPAne*^1>1R#%b{^$Q3{~H~+8W|V>hB_aG<2U|u00000NkvXXu0mjf DPt#yO diff --git a/docs/html/img145.png b/docs/html/img145.png index a83c2523b21ff3cb104a1130ccd33536aaea03da..dbe16817bfe57d86e07fb9270a21acfba5acaa20 100644 GIT binary patch literal 481 zcmV<70UrK|P)F5N0`p>ujbJJOk!%aN94Iu1b~J0c!FD zJhtMIV_@I_o8-vAAOz+zci?s#J~_BafeZ|yV8yEpketvqjbT<~HG@TY0*2hI@QebE z3e{{D2j;L`0;>Vbae$;+f#GU#iSW!CP?ff%K^n>IXMroAHXn)<&ZT*8FB=*MkX+92dbEw&VV7eoxvuRds`Kf zk6C+vfD^fD091gv0WQbvz`y{~tHOXOXTZRuz;BG?NQ!_TmCRva-G?{xjDk@x3h)8| XV{cr^g%W}#00000NkvXXu0mjf|FFP# literal 572 zcmV-C0>k}@P)OW;0000mP)t-s|NsA) znVENYcU4tY?(Xh0Gc(N0%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001 zbW%=J06^y0W&i*Ix=BPqR7i>KRJ%^YFcdv;(^Tmz5vUu32@fGaO1mSq5@KgyWT;r! zfPob$MPh)Zz!!AvhIfSM2XqJndp@D+PzfOfcHKwPv@~iLK%Bvk>*M3&>jyA|0SXY6 z4I?flfZ6ocupBmil+cktlE-R_Xr)1TsdOd@<1vH@i;SWr3X@pasZdI6qW1^*y0JQ3 zgWF)G@VrDc`MLe^q;ZRi>5q`sSk`5)c^HQW*gc;*YK%0SK59Tq9G-xVzXE4Wb^;(g z^%;?(bRfJtLSy1;GsH`66D zxv%|hyyiCGI8gK59?c}OgB2z6ejh58b#ltKBsL?legVQSW{x)$4WwdDCr!bgtj=-M z3oK6Ns@Atsscva7ymuQpzd6k|Umg}5+_l9uR9Ad=UfHPLT^g67jk1cq1Co5@hG5~8WW$mq)Ss`$l?vnL&1%iq!E@Hq@}0{{R3!y^%J0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HXGugs zR0x@4V4w-m$V`|OSoNOy)6fFw;A7z}_ElLG?-0M`5y U2n`5|z5oCK07*qoM6N<$g1-D(jsO4v delta 225 zcmaFK_U2H&YTex z6kN4xRYylhT3Q-Vp^J;l-Me>{l$3Vw-YqYyI29R6&OEY{A^jb@ej+T?4Ob|EF>f> zc2-K*HSpv=OicLI;IFJ^aVXOuQM&rDEqkVbe+fVHWG3eKbsMgH<(@9NLslZfOF~AH ZLEwXEZ0q8gYk^iXc)I$ztaD0e0sw!mQ>Xv{ diff --git a/docs/html/img148.png b/docs/html/img148.png index 2c8c4c5960ec02422feddee783e7699c003578f1..112296d4f591c07a419b0cb50649c279b13d3d7b 100644 GIT binary patch literal 8250 zcmb7}2UHW?_UI7=RH_1MK$=JkMF<_FBhm#zM~Xl~uTqp=1OzDp2@*mT2oSoVBV7W7 z-kTKZ9R;b1yx{lU|GMA1_r3MrT3MMhb7t?^`^-7}{ATYcZLKF1H|TE=5D-wPswn9a z5Dn8^X3f% z0@2gcQ&dz0fk3RRtkl%hRvVo4c!4XPx>{fYxz$N10ReNZs*=3k%e0+z(-?*|ug-YY zetsYJsc9M7SAuflZhT_Z4OJC|7%iA8HCt%fc+AI-4{XDBlX43{ICRzhyUH!tsg%U= z?)xeWWVDtym5exV6J}TOvJgi{QAk~xzM;U<;oB9qzyfDJTR_QwjgU~9G4mH9VcpIj$iukWS#fS}K=(e7NB(~| ze;6Q0X-un_H1v(8dmkXPV?lYxGe`aj=}TpsP{`R9W^UI5Ley!U*`euWNtE>Cwf7!E z*|7%LQnY<$-UULUmS6z3LEOA1?n*Yx5emM`uMc787n}oo8DaJT%`oX zdYK`M&5!iM*WSv$K3)HM?Fb0rm;25sa_DW6S-f@SU{9l@mGy9(t691(LMmEzl5}O- zKOB3-8(dOr9oXo9Hdpm>d22-E<#Oy+`R@ugOysRSzMs4q%1c?FqJ_rXo}4uR)V0fz96se1oU! z2#;s$at*0BZ~4nDWfk{78bkYB)hQQZdbQW%i<>W!6%UDgbz2HPjUhj0H9+b413hui zoD5K#u&8bA!;k$6C*K`?iB*AMQl~>$1smB!%;ZDHJpSL`D}e{zyY!WvQb_37#XiQ3 za)Eri-~*@wxw&T}9RARHjOoSqW4AVPqpJ)CC~Du(LF9>@3E~)jOBDbc91V! zEU9nM1ubOoKKW>qHbP7q~ISze)F`ex*yM1)jaS_FIv0tU}R?>(h%L zid^Ov6s4n~JWnqi8RHm@Kt%kq#$i|*FRtd7zIy;lu41>AqLOUE@K^>}uTJ{>Mc z9x%JJk?k=x2{ybWT41&<9lA;&D-wA*BZ=L-wmz#Y1oYE>Pu;}$6w0#C&@W=m=v?Ec zqF`GNCHwE1d*bqT#Jn5}y=*EJsA!5d!3IwS#&##|9yA@EwQ=kszYsIExAym`#nFGU zHQ=1mngLG57vwuBAUGfTxMbcKfr(lq~Lc@F6S&dlCiw6d`UeVn>}MpQ&zA6{}{ zaDJ-1c0KxHtkBEnD)ngMj3QxCZ_&xm1D`Qdjy@{)p+{%3LA8f0gugbXor2dM3VidF zM26O%VWgc&a$@$%Z-b?h>H>{Vr>bh0 z%Al#FBpqY0-5pZdsWbE8J9oN*bKNC%8jf=&qA2Pm&g(tA(Zc-&zi4v&QeWug&@Ce3 z%?BwR{NVH_Mx{X^y_OuFKGxpK_5Uz?JjxT81x)03J((!-(EgeKRSmP9nU*{*Y3(DV=TbCz@S zpMJ=I=tB8sl;hKS5DmWFASNXrME&zJY7gass8Butx{ur=w`M1=IHm!^8KhCIEJzUF zP%L8>k8Nx7uEMwq;hEg0SYNE~A67eEv#Bxj?G()48WC|Bd)jd`Qw2X|q$rZXwQ zDk4zpSTl-_Thpk)*Wou4?8-jWJ^>j#?|I2Ja&PwTwqfswD>pQa?%s?#0!I5iu%@eu zi3Mp2`e!+VZ7K@G1naIc+c{EH#pHp`oIVuj=8#VpsUTiV_mWzlWVEg;2Z&~0!2uP$ zfzQ}3MZ-bP9~kKDkP0-nm6bj;Mw@gQJ?5J~g*1aCe?;u=A=RA6txVyf1{C4;K;pWb z<$tc4Y6HNyx;?nM&Hu}6y&lwO6noygqP!(c-s)t3XPQD|`o=jw`7VnLsj5%S9Dbl^ zZnk`1O}D>(Kdp!ksxGy;S51^uto zG~_!+73p{NUzi%jPKqQ=#P9*#;ROu`+`c<@RjNdXZACwaY58>oz!aiDu z%2Of7$zI?sM_ZmD*QFAQ^e-Bsm7mkOd~2omv0nQ@?d@5g9Q#SNcreoOeiIrvm<(5G zYxSm;E+YAhUDF7?NMa57p&X|$E?HUF@(BgF;+5)HS9hO{;=xdc%MfpWRHXd56|;Cr zjF-7Pa~iXH7G>u8=z{onU0$syJI>gB%p)$# zYu?UEJeS*d_nDdY+sS(d?dzP?+!p#PQda;Vl$nD)pA&BI@9mNrsIb6@+~b78U2FODz%hb(WR?iJ$1o68DKs;`acu%1g> z2VpZxZQlwo(tYF!vx&kVCw~d`7+H**1l%-gI-qOnAMR@9#>g0FT0ESnn!h8+oG>vt z*}@f8YQC(}fzOUW&F~MF{IKim&E^Z_x-m$xp1_b6)q{U?6mmLz@r3+n*(C% z&>7gVlJd$^qKzvXxa~NTEyv_JF&<6(Azid@H3UcUOUkf@h#@8K*rq_7=4&&@v-H~f zX0a-?trTj9wtuYT5w+}F6c3G3>1%lnKZtITulMJ=dic1g$kTXB`1g@)2?*EH)LJ|j zM4$l?`VpxaNaHy~RGb!3;^(lAGnjPUf6wZ`q2?MBegX9n8$AVR&b&uOeTJ(OJ^6cPBd0yI;xs6+b|d{%7N`v2 zz8|K8cC@r+|5eFsD|eDgwbKw~-F zMYUBcy}7r4bg%*~EKlC;02AbHNq$bS08`CXJb+8QRqf+yK+NjY-o6W=Psutj90X%2 za}o5C25^oy_Bp*XjX~+N?FLtmMzT9_#jSgIH`78G^)XAn)S62Ax~p7)OUXqkiyAyR z2k)<}|1B3A-UQ;1m_`Z^lxMaCN>+B5LOG$2+H;|9XB%sRg;QF+E(R};zr`B!`UcNy zPDXS0-*%Ng{rc+(R}dgnNC#JmkWx$~SjdNJrC#*xg&Asmb;u|a=lON0acyTLdm|Uh zUS?WhHC|)rS@eF9S2!NZ5u-mw)1ueFnU}!7XKt~v+r-U2@9eAp^q~Q~xpUf}+h0y% zI32_|k}V&B&M+?q?iE~|ZBiVR4u``r~^9ZSSz3xuxpj}?B8g~uwl)%>#l`?>jL9gONRL%l5BzW?)uoGx9su_!|cT=HggRpl!8hy9ac^*z^* z;c#il;9PL{Bf|&_M8wp3md0{C&#$#yd>^a=FCJo`eCH9PFC;FNqFFb8!^4Otrw=?% zT~#8pGW-+y$U$@?@Dj|zA4M7hdS{#8G%LvvKFibc)MG=^Ao7bRrsqWrT2Pl}I}M*d zWgI@|?9a^I@bJ@-W<6{w%)==lfoZG_kxcQTdyLTv8HKo9(;VGy_Km>Z+Pja=Y;dL9>G8xlICZ>$x~dNf^A??wt-h48vgcX zNyCY1;Nj~wGDBzeAJ{Sfz!|g~sH(6zhEm%py%sgCu`Q;Rk z863#D(g-X2dhh5*y@NMPo?V1iA8Gz}lTpY?r$4k+uVW6#z(?CuJOc-I@TRU7aM=oz z#kYT|K9Y`81~>qYJ^&DK`>JQz_WiI7VQj$ykr`*Ai3u)&62PFVoT&+;@8xXTO->z%i9Ui9Ztx~N7?S3J!Ev!decXk61q z`Dl7NU3Gf$ZK25?()*t_em514LN&`qybG@>T2-pc|1-qmQB4%;0=`}GH>%O*pZW+B zgR7Y%U_9@*D%VIj_^bd9->1S-emSsj?2b#}dG0=;_}nL<4$Qr@qOl1UWA-l;8YZ7V z(%uqljt;V33}W%dV~iPaL^Qwy3i(#H2i&|=Vr+#xl!pZpH@}{oEy=e5W2w-dIBjjn zhK(jE_&)Z!CK7X7K*@uDRJ!YW$s1I$AHj^`joM10q5H~lj?+Nz_>0l?P0?fRG4UFG zPg%4`@W9dSUku`SfK1c`$QBH9hsnd;R2pw`rQ8zKva8iz^8ewM>z74C|88WOm%c68 zeCW!1D2vJGLHE9w_3Yc7>zhYi3=`dT6jWjNz7&iTNVL-ZzLVBq>e`*FasMxMo8}Fu zFzzd9H1r5edBP`10V%Os@=l)*k@u)T>M*4qIB{v(&?Ht;m~$FCn)dSUXuJc39cL|w zvV7M?n%z{S^4emSngxQccCVkkk#HexFvi~MF^{4&*Lt6Co(?UCGI%<~LCs@8?d(Me zl4jnG0;$d1WA)*>id3u4HMcrf+=EbH0Oap4{uYUB0HohRz97;7<)Uo$mvlNT>W7dH zHPi-{Z9+5((rKSL+X(=3+|&c`U`U$57AZZn8XNV-kaG81TkP6Yy4a5TOSHSIX-|sg z?so4x@I)HzXH0X2ZC%=~-IH-1nH75se%N(%eVbIDM6^$qL|@lJ7RFUxuybwzH6mp+&MxqA#QmI;k5P z4q-79Ladck=+`(!)GH_y>!Y5d%r&boD1D6qJfoc-9EZ|NcWDoyzC$P?4z_=kZ=S#7 zHtyQ(VLvH?taaUd88T5lWIhOSXWm?es6r>?nCphD1e6@q|WNM>x~-s3h@Z$Sr~J1F5Y;iYO>JT@g{lbgB0Y3m+R91 z4t`;PzQL5E$4|Q59$6A&LmLEP)v-y9~>m*FW2Emdu3m*O>A8i-($3{TD!WjE?bf!MX)IcIbSLe=xL}E^lUNIJ z*e$st&DQ+TO6Go9MMa1XiCN>|CBX?h&q_YIs|@fw1Wh$6A+Aod^S?nUAvgxd-tK2K za^i&Dw_9%2y-S$CBOhmX$oHsHrrmtt^^v=Osc%vjBm4hjaz=kVM zpQtn#4?O2aw9g_=^(;;oN5N__^mnIi&+=A0JZhU6H!qv|pw!k$ zJojz9u>H^@NN6sIXJ_>u#Usd{Yf4;1Q!eSJE(y`jCOTZ-0gxkR&A+=I2wYk)QYBJ2 ziPG{?jv5dMx_Gn5z0}6)?4QeVRo2${E>*{8TegJeW@(T4&;QI9d+MQ#DjZEMOMtv9 z7x!jcfMFdH6G4um<=XPD_F%TJ!8I;D0Y^6t5Qg99hLTy&O*$n)i=VDed8B%@TB*Mh zofCi%oT=txxcNJoywcc;vIho=ll3A@)EvKK33$NI2u?nqMo+Q4{oD$qTgk-{T^pBe zxsh(Se$aB3PWCv6%3EoK1!|zk(R>{>dS%tPUBatJbCyx8K#mapw6?)QSlzzF$9}VH81s|>imj(sXNhWcB(61S0)}d1-^L{XrB^}0}%}S)s zxbE-hpf&5!{RlZNSHwyu{4(3s{pA#_RqT4|-a6e~)`H(5C8~g&dg*)Y=9J!^-KPnD z7I99}SJPelDtVE%MO$~ZfOh4e1>C6o+XWuQL#p-0p>NG;23?fv&G)udP^}*6TJ3Ej z=NS@PJYjsUGqy#cQ9r}w4I^&QWu5jLMr<;#JEViF=WluaT;Eg0wp05EL&&&T8zrCK zH`{DkHYFOd(w$i%d0exY(h4RiqUUXL6t;M=3Bs-yg+CVAzK#r1(g0b$a#VgQIY#W6dAUQ%+5O zgFEEsvoIOwygci>16i(;3PBI5Yj4r-M%_Aa5y7L8WMr3eAb8SXswL}J7b=EZ?;V1d zj>6<5@K|yGK@Oc2_ui7Wg)z|)S>2>9K1&++39ec~BW_2+^TZn>plVVi&t0OnCZ;<( zLFwtV!)*4+Hf~EHT~*gXM{9h#u1x=&&bFLhpk5o>Y~hy6g=w7CvTaqnTTBw`2{}p| ztVX>CmFP>BJSV%e(-=Wg`Xo3JJ@mi^r64ORtSMc;w;P}uHkOruCZ9%ijl;B2RciSn zPG1$~9Bmd9EUHdbo`yn!`__shqjSeh;t9e=6!e9-cg~xMsw>Mg?1}o4>3GHa=4?b0 z_F3}cQKDe8vD?>zEq)O_pfCtiMuR*_Ust1`kbm7cbl;koJ}1U8xv;_>{>rkd+fu|X z7Z_H}{ZT}OC#iUNgWOaV@-3eJbkx|6x^UFrfI}t9i$#xn6gL!{Cbl%7pwCEfDbTZ4XhPjR7>qN?pVr_s*W* zh~qtGQNcaL`^V4|r!5tI63rJ|NnV~3Jork?V4Td^8)wFiWGHAL(fqapAEtC+L+|W&CqvjhBpUX<`E1ta#9zu( zZy^SGGaGs4a{v#PcZ2_#ZeP!h;Te`l_VgdPH{V7C5SIiBoz)O9TEbg%ZQo8WIlZRI z@(Kn=BxZ0!2LJ6Wp)Xq$cYRQ@gs33(1z0wLY96_7 zTC5vkC8ZlK>jmH}GrM!@8mHVA!Os%sN7$|Y zTLB@CAO1?92JeI}+@0S(Wzp$uYw2Jl=*$mmzGD@Q=_pj|?-UZZF(lcLT-%~0rGfA-0cU;G`{ZGY^ubNqAQoI!#f^g$xQtuiV~(-0%LEJ- zm?UcsQw_!f^`MvOmRNn5@rASwDhi)%;fkLc;w(*hQ2n-srB-+TQswrch8=U~8d@ys zi;l^;WMS)YR z(Gs4!HS{_OiWn@XLce3dPwC-Gb4 z+hem%Im6-NA^dnWiD%@%O$dUIYD0WVIaNNOTm*GS{W0~GvN9TE=K3R*JQ~u6!oZ*zQ z*|SONhB9Y8ME`TR7J}8=;sDmFi&Q189AFNqbK@Uf5jVT86@wam4(G@Mm5*I9JMSkk zSkue;Nq>9&vwOR8F*#IDT{4TfXy&<$?<8!=lU-aeRX0*Ul(OL2W%02za82zHFdee% zXp}|M>3pg_^PmEx=OFYo*r4=jJz?Ve##?EkAQv4{J>8T%faRu-s3kHmiFcDQUD&1T z4Ln;Hd7ZSfZ6Ig|W*kMPd4|uih8y214YXB!a@Xn(P*HU$BE|?{W;^O5$3vHSqXcA& zgkQIU+?PTW%@@MzRQ!|`0Kh7Qn;g$Ta#2zNE&S3zFX0s!IHHaBkifM0fP8!K*b+@g z=DEw%hCDI)`|gL#;cZe+Wby7hU)PF8eJ;l>sA-bwS*7GLS#J4c;7fdexs-&Z05ma9 z?qVqI!ataB&+3Ovip8F33+K%e&G|lSruo^|yX{$`m||9vf2`T=gY(SF$Hl;A)r+bB zqc-+WK>6p4`|oA$ny-5U3Q}k17Hro-S^oS4)_=(&h_7Mg+HzX(1$_e5$689I3YMY& E3&@P&1^@s6 literal 8603 zcmZvC1yEc~w=EXjEw}~^KFI(H?g0h}kO0AlVUP^&!Gb#^I1CyrB*AUaFt}@g8G?Io z4Gxd*zyH1OzI)%P-KVO%Pj&U~?!DIPQ#(pWOO=F>fe-@&gXEQ(k}d`YmKX*G<_Zq> z!`ll$r1j7tqNAy=e1CtRk&)r$<@M&xoBjQL001yFG(Hk_LldUEu9hB#+y?5QpAF-clDxim)}E;ojI-Axkf}`V^HY2JN1!;w zSJkJ=N6e!#%6z-eE_D=0OnM`L!Lp|(8{l62td3AiI$kEW(BDm3H|!nkQAuVomERa8 z>@xTH99L9YqZ_eQPV!6h?l3bIL!L6=@Q!^krir5Z8ur2o>eWc?h0xd+^5PoSCU4Bj z&b~cz@!S}Oi#uTu5)S(dHy^}FJU$c4U$M*|G_%z&=O3KF^e1iC@|I;*3u!IH=&&^! z8~4rgXC?lqTk?X#%U}Q1Ont1Aqw-?8ZR8gwR_nhpwYk`MhrZiU0W2-vWPxOVGl`q* zs_`H%E%|teKxSPhtzUh02*;xPl&t1T(NUl6nnYlgdOm*i8(6)W0+ToCVeuomv}d&g zXw6cl_6^DG;PP^ZLOq?#$U8@_g8CNoFxI5HK2>eYXti%5u|)F><5=X*m8>)89+`*0 zmrbUx3~?0K3DXi5Fmx#yR9Z%6UL0lIAXAU#Bi|Pa?v~1{ChpTo+bY&UxnNkoKQL-o zRP@Vba)S(Uz*~c%0nHMlGd+_O^xNmJ0lMQ1MG9{EUSQ`84w?4Cf>Gto7`(vBY0x{_ z;xK*cU|084gjxvMpCTPKsao)6S5SJ3kLedV(k5SOS`8>zm+-PZ{f6Oh&sECXG>`M$ z$h>7#laa+UJ95xJSF!%ZX`xt!g;#YQP7ZqTfuU*sVPjo#QaAolFk*#=N?-oO??ZUHY z!Z>$b-Xax4o6f5e)9Rnbf@4xcOA=#a$c$c_?)DLhN2_B9M6hs0gW(CRz=4qU9pi__ zKWWnHmUR}iK{fd5Gi{n)db~X0VLX&m8(KUr>~{IYqty29>z<$QqYqvrf2cfi@N}2d zRwp##EMoW?&8IHWGK3iHzD%a zcokkj#JiFl<6MGqKVhNDY4-OfExzX@j-|B*sIB0BzbMxsJ3g*1G8Z8g?=Mzi)%PR=Qf|RF+P6usryun-sI@MN*)teYJ2|8uHb@~2vh?;gl zMQZ7G6!W>U7*|RZtS!AZT};*xG}KdUN=OEf<}(uQ9}_N~2fZVfWV3u z^J*f4a3U3$85g`{ec1>Y1<=4gDB4y`tE;I%U7hY8&Jy){2y72urH|~4Vb8=)zS95$3G$Qc`KSSZ z51+N9;GyIX~{TP1#_rYc;_FOhYmF9wO(G96qP+3~4PwDiBcdvfDcEKWDQ44b1tWzvS@2y6uTjW#e;neiQ-$du!?YKAuwj z?NWlR!{QU}dAZ@hi0LK(_ii;nA7Dv3&A3sqQ0uhPe<`lvem8298d?tBQH>{nK3#T= zsoDmeq9FQnIdr@Mf+J+|z_*g6g-Kr!)%~p4us+@-RWftf40IZf#n^^8On+M9;8MJ| zr7CdywIfnL{yO@*Lm)>K$x~Xmgxk+~Vzmoi=ho%Jm+fN!G&ns@P>PPv*C)vT0@v4r z*Wq&^)df{Gdko0}=9krlxGPXQSyxxXt2q_Q>VB%EDtbk=X^C}pR4g4iW00rC8Unp> zZ}q03@}0?m-5+POUR$+H`vrwNObV&cN6C)Ys3f#OVupArn+<>J(bqGi?#c%hu_ zJvVX2$$3F{gljYc-0jd95_>zmWuFFlPjqQ#CyR5Sw%QfhkLJC*kx@s-e3>ri& zMHnsiMqv#EofUKxyG3|>`(ZWj8lmgSffwctV+)t>8VC-H_|g!dt54Mk=?<`~oG zub@McIecZ(X73p(y)7#K7zLv~(eb>2mA}~!v9ul%h@G(_uF2nX9jti`vwItbQ8`jw z5MpLMtXZ*~A@|Omb$@A=5`4;2j5_+g^hnq8z!=!Po9}`MtwL{o+S~ymua|D9EyX#0 zjQ(P5BAD4d>sk3y*`HoXva?%Q+UP0iC@88Sk>>FL2T#6VIqF`6m^9J#DO3t5_ZH#8 zko8($>6a%ePB@HhS4!l(1$Q&>;Hh^5P;O@P#(tfP4@sO@uy}{xjxRs)bao6BW9Y!v zbZSmqsS`-XJvw~VWS>W{1sL;0ZZvB7(ZLBY$aNCLJC2hZ@Ef?`|7cJrLu&O@|0z&Xq>PxDm`^RK zEHlRx=~6jo;d~hp_ISCv|9w(%@V#y$M>}*x!NAFHm;`B-bQZotQu|{)yyH&yksLnU zPC{B;q^pOug}UTykSIEiX<&j|^$106lcWmK!>cBl`SITCn42?zZ=eUSm19?}9i8mD zhrs4F6J(J(Y%b}EoHMFfmYFa$jbJH`T5BsSyZsDektA(|s+H#b)Mw8__2r}bUJC#T z2?_1K7>d53W|aKz)?-CwMG6>yR>JIxqWkObo;KgNCzaLpQ?Y|@Nd&mJ3@bmL3rjj@ zOn-TB=|fpHE&yCG`#mAJy(KZxvn=jqWIH|_uJQ>~U`g%?WtE0A2Ta)iIW!#Hgf4MV za2kQ!E0nD;))fPCic)_QKht*8Bre8H7508eq!F9x7&#bkx?bBWTun zTZ~IvTJk2w$|73Z8}mOr7HuycxGP2+or@3(z~>&8z~u{V(ruFIYyVHeF83yo+1cYjDGklGoWc>7@edqO&JItLR7L;J`uH#!whZ{GoSO)2u)X z$%|X->c*<^ptu!ETw09~l6+NFFbaQmJxIA(Wjcp8EU?(ME5m{+uwlDu1>T1yZq6cp zg46W0p{UTZD7L{7q5z!FbN{d+*d-fo6^p>KgqgK(Q7v3Wg9i5xl@;IiE5I3d3+{Q% ziVZe31hBWQ3R&lCo+S)VW_3?Iiya3{hx#I5AKH>Y*L=}Nb9uEWhPVE}cb6{Z?6V@3 z99mv`t~3VznteT?zCtzJI!rS5Wln#ZLl+jzA$uIKNe9&L)o|_kETiD}mA)t3M#~Od zJIW#~!3$%|ETg}>ia_UFw?$wM?6io<UB6;_~$Sp5i8qctF`AU`?i`jIef(5JF9C^1Ae zq%uM$!=v}B?BpNU33J1rA5E_l^^AK0N5!TLv{65FeVA|w+1>9zsMQ#*ZWXVq{h>z) zIgsb(yO}~?Uk&eS_lrRBy7}7*IW$;Om?}vKEHz#mSW5SY1=`s64q0gC3Df#QmB9(; zkZ++3#0+lVyK{=Oe zjsM2pbDBKc#vi&o*0PNOgZQ2D8t`TplMN!M2flN%hN35qtPy8clACW!M#Bppr`DvN z@z3cPH`(4s+Sz}fy6$IWSi~LU{!RyQoP}YP<>G6+T|UXEcS-ia-yUZX4t0WPZlEH< zO}W-Y$bgOVRi9UDhc1g(r>cZc%GHuUu!{H|#jxXTlt7{ZUTMkxR8WCVsR7PQSFmWT2X!g}oJJMZCQdj%fS16)JnN7`!GJA-dwGrf_n6OcpFoHkp@Sp*Y00q4 zxfx@tBvHeVT|?C7+S^R8kS}le$0`q(M8}*1kcWdy$a%`kx1lvhW1W5P7e1L#@oco7 zY`rhR8xXmGDSm*(hx(AT*E&zoH`KcA!QRYqHTN^_Oyr07F73?Wi#u$k*BudN5y}yOYi#Pi^M!Vupf+~jA!C3Wpbb|M1aJAlWYQEH8U-J)YlmU^bd@j z534pY5u?n9xxUAaIAbK5i59!vU^EiKjUL9m&;DX-+;Hwv0&|_OjC$o}ll1g~UX!)q zOamn#()CI1f8;C$+WmxUxgfHdU81CtcyS;jcCa{FJvHNJ-p%DKzipW1q+m~Zn-Dx+ z2>vdc-}T-F*Et$BhU~W;8nmKZ@9bf@OW(-)wi`YV`d#c@88yNw_yTVq=(oG?XUY2> z<1c2~XRszm=EEHoE?(#0XyF?jozQL&>gu5{@TGT5xcsYb!kA0qaCl9FYCRfR@OC)# z{STuBi%yV;hWl%QLNIeL@CV==rd2O?db8$2-Yi3vHA^o^7PK;4hI8wwK_)E zp3}3wwFxg-;b6-0_lmLjGM=4Ijbq?)ZiqRdy+yIUFzZwxbrggT)&>?e z!jNY%UQ1;gCxSy0cvbmLoz>Iuw4lX+U!)vp4z>)hfZjMa%{f#b%~APv^W&q{R;vRn z_&OWwqC(nuw1FX9Sh8o-d-!0%{zw6Kw`qPk?ZK#>W7Ko?`2~<-jkZ1 zJ9mkWqVzWdTx)dtg?Wy{BhvxCmO+e1$)dx$6!kIH|Q z)_4ANCiABKd-bK4hmAgft6f%0m0Xd|-ey5IS-B~qcS|cSu*FB<*do1rh3A}AVpGyLb6k5oVVv-~R+TrPV0 zFI*?%g$>^9c9@rP{28NF_jRKfL#pUsCQp$cU1F|Oe>e{V+AUHSo;-0w_PtO<-?xgY z%SlnF@t?(X6=*m1dUa-eB2Fm$bC(o8j-4${b1@nxT;W?aojSI5Zf~?J5PtA@$tYl) z@<#X*X%%~=i+}~MHavGC8~o!okuw#-Zx*aZY&NOVnJUsMd6NxCIJlSu$@kNB2yj*B zzU`+2;gPyD%o`jf*}Xg4@c(#UX<3eeKB8r$sCi|Sh+VYjf2W1AGc4Zqr+Id=VlH=Y z$Fbw=y?Tf%JJmuq$S=lmUED`2K^Z{g*Od3cfj+sIM^T`kc$6vrqj;y}$aI8qm$wJE z){V_=*R`FpK!0W1jCVxi-Y64gQht7hlbpxqduQiA5fUV98`M#kJQv69lAmMK874yj z5#E1}K35#)_2^MdCJBu491b-m#lCdI_trn=Qe<#j8KN{nMyb1+J#k~n|F5Ws<;%ck z98eswpWzg47Q)SwwZ0c_z*VQB`^A=v5BdDj+rSeQI2Ao4i`i2K@Kh_InkR~~y>d%# zO%4$|bd>%oKW#+}-dpnJeyP%(G!*_S-#&l<_let~lR(|+pTWGJGxN{TCiUAJUV`O! z%l+8Co#AB6PQmexu(=uhbFj$%PiuwCocp7BlupPR3#{WF#-=M_AGg&wee;W1OL48) zmM9k}FGICi;GHNxuhkrx@Vauud%?D;Qcr&U0!3=r!r!44whwJ`IzM)t&AGl9AP}!t zmy6lOu2VSxThf1zOuU@OxzyAz@lG@XkJgYH^yNXMoSyl|$nww`M_wf&lPnm4UgA`V z8D}|^t#69zrt=sX8D3w%dy?ERhy9B|x}S|Cry?J{;@CKo;T+pCCQT0$yQyH_6ldYF z)h(n6qEQ8k6tr#I{ESX|LZjOBn`DItqlrJ(@tD!ozYK! zOg|L2(;K80<+5_WFm~pkyrbL@oEM$_K(_Ev+8coF>BErJ4yff zR7MZK$!qC-F>`J`)=B&)>cVaNy*p)@ZiW2v zQl95`u(d(R?e-RY8Q4A(pUYC^SPA>sS%!}Qh@&6~F&?Sj_?Bl}^rVxuq@JXnp$+uC zNRs6^PqVx$Zu(>hOX}`=L1*K>OyCv>Gs?QwY3@Px@cXj2#)QP0z}$pw&XzmuXAxh2SA(UA8dnIF+T9hV@ZkK;Z$a;) zpL}GwJ;JK0wIo^IA8y}wcx;s`;;j~#2A&~Dh4q$2dp?%Kw!Y$S{FSvzZI3ITrF$8t zVAt#MJmd;WyXbDx_oNeKP~;_!$JOa(Mf`l_D$Yf*vLYlQBwA~rDq zGTS^01mRc`wR?sHpgX3B2`7&GpD5Np!}DAsWKP!nuI@wpoJEF&YK+1`yM}Kx*dsi< z`@&X1tivjHaf8r{A5d9uftlwstf3?3XX=F9iG6m?s}!O5eXsMtC!;7sjYphPnB&}wIU=zB7j8~346vnWih#opvR;letv5!di=vs<>EqLpJj+>0 z-ycb~;M2+Aw+tp!E`KP0M6&^)73D<4A9p=6!-h}F9o2F^x99mCde)M z-QvNnwL8t`N&5F&i@BPev>SZJ^3BZXboQW!(rL6)H!A(GgAd24>X~%I=%w$)Wxo*( z=IT_2C^+gyz@&^WZS7DvoKQtTrp?Fe#{v&jHyy_F2kHV9T` zPGt28e9=VwxtYH44_a%(xEcha{b5{ZkTyVA(XIqp+v@M>S0SOOnTq$OG0pk=;3V;s zc>lkt+e*FImI9DtUa#L3%g#bPC6tTSrvNB$K$D#v)s=^AJ9WBZ@i12OX9>u)#lqs! zU6$!eDx#T1toZl`eh2hsdI{s^3W$aBv{`47V%e78IntG<{XTa zc0&^}k+%X0xCv%TvRVG&5i5lxbP4oONaBL3X>4saTAhli%pra$1|8fAtS%17k=dQqMa{k z8Owg(>bH^RujKyyh|Zx`TcN+S7;JU5`c11r+VuiEaDTEnyTRTqLD;JA`&CyWaRtDy z;Oryh;swrJ470n_wS;?GJM8h&tE~v#tlrqKBEcXZ1v0DBWHJHOW=Hg2BDGQGXkAxmV6+7a1E+uejR-#qPL_6#f9jAc7es9Bx0LKG!&OiegA$ zW5T$>Xl)1W$B8BR*2gDzdMZ7MKF`#hvLuzUGcvj8G>uS#>te)D zKz%!f1h(LzQsjPJ3`K%Jo%&?bKcs_7WFI#gp#^Jf42>ZA$;(DX!uF<)iy7fTt=qDm zXLW#h!%P-?7rKt=m;~4{9^B4#R;YE;~YZpQr#|b_&^W z{xALlYe2cJIKmVQX|Nh*lo~3F3D%*F1U<(gv_9F|)Y%SQ)h2t5;|?k7+e*00v?_-e zYOhp+&uvr+opt<^{`1NKF6htupXI-ZGG91jb}M$1H0b%A@ue6a1D5urL;N}4E3oqfgrfn%U-i+Bx-Fr@v zyixa))z?zIAnkCGetqrY(9j0CzD@uW8+_>@FM#BqT!1S_80+13Xv?vxZ8p6+{fO9X z_`0}(FV$y$oU26n+?pLkL9tyEpIfdOHQeF&kQOg3pl_!BC__CqQPd{pqaAoqv+E!3 zy%;-U*!m4V7?~g?aYXuj8%v8FY3TYjZaYQAhaf6Rci)NP`oz(tY*Cz;OJfYZ3X95? zoEH>#xTMWeRy7yfatk-leAZ548r1B3jBg881^u4?W;UcxX)fkBsQH@Ce$3BC>-&?$ z-F!g_Z4&S)sPic?1dtLkJGQ@Hx__p-S9dT1nOw=rJN+-2@gH}G{|So!RwK;4U4)i> j*CnrY{&^&#?(wDw$d5IlSrrc%6Bw_QwUo*gEQ0?JQ)Zq& diff --git a/docs/html/img15.png b/docs/html/img15.png index d9af05b2e66ad2ffa69a7427acf290cbb042556a..e10abf3e540e8af56f560c712616d31b5cd2ebb7 100644 GIT binary patch literal 223 zcmeAS@N?(olHy`uVBq!ia0vp^xydkwL+)~SzVf`d+P=w!dj@gqsNJmQ!@@6|uNnW=AJ z6V%YTS;W9#hjD}9ah7S!ybfyKXFs#BePie0DdkBxGxflhtBl>7XG%!0NJ=oAU=>R{ T_Sl{cXcvR0tDnm{r-UW|3O!Cw literal 230 zcmeAS@N?(olHy`uVBq!ia0vp^dLT9nGXn!-@QOl^gl>ROi0l9V|7XseSzcZq8XEfU z-8*Ar<1=T@2nq^zbabSpr2$pBxVYTCdsj(GY4`5kWh*vo0EHM!g8YIR9G=|($)|g| zIEF|}O-?w#Cm|{#QK5dIB8H<&pTT3Jks*hHfq`;%gI3~%%9bOU83z(=@(wKOSknH! ziDA+dM~MjmRR>NTI3jRh!Uu-=noisW9s=s;4(?>sYFhSBgn2bX%pA@WAuR!7Jf(6x Z47W}A-u?G$zX!CE!PC{xWt~$(69B#sP_qC4 diff --git a/docs/html/img150.png b/docs/html/img150.png index 1b52ccb2faed93dd09781202c2c5c9c956ac3832..179fdebe38ac0268d40f882ebdfe496480991223 100644 GIT binary patch delta 961 zcmV;y13vuA2+s$Q9De{nd9Bg_001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCm1zTE>l7EX8ds?-TLM!GH2}sZO zScEDf*a)^#1nDIQ!GlPJ3cXda;Kgsg*-dsfX$;vM{9u~Sm-pVhm)V_709sjLqos09 zRYaPliektWK4?IQIiNeiJ(X*^NnXhI&R9_lUnLt+O4iT|SZ|soX1$Z(p)|8uBdx3f z?<9Dr&ftz(P=8S!lvgu4u>5mhsJRaX8MZ(`N^q62Fmw^!Ci+{Ckr36#G(HRn~Khb0uR0!|P=N zI<4*uM04GS9EyE|C5TL@7Nqrv5F0W&EVwzGqmkA%n}4IX;3-_fcxIOgFpenY5H^4v z#(`kGO7L4U_GFc~3c42(=|Ww>VceMle9Tlc4GlHajg}s3Kf2*bhrb z@lYSNRsnM)o#m3C_K8sGyn+rPijMehMRxIpWE@xF9=Ir(ar#8Lg^}4;R9O-7)i7#% z^~%M$vVSq*p4q5|rLLu_L$z6O`;^Ji{nUCKiy59!*rib6cYA#5hSEy0Ymy1gmGrqK z%H?cHsH_P2Y8bU^hT>e=SUJ=re;qQTSF1vuHQGU2N3`PZR3(tuKLnK^1Iuox8K9j4 z|4tnnO8E&}x)W-(Hf$AqdTtR{HYVKT<=15?8GpC}-7#ONU0g@Alyyi!yJ!v>h;&1x z_ztjLr5_&)18yjOP~bgvS~l?=8z62te<;=izbq#d$@7m{hEdz2R|XJQHYVKTL7{Hr zYJ>U0Ye*ac4MF)Fe*xN~aTDVC1s&RYd-0H&1-AK+2Bh-O@MGE@`)DmqEn>@lvf&)* zBY)F5lraRX7kQ&ov;ggEko#C z4#OiI|AhEI=fPL3h4iMke3H5$!vMX)Jwd+D`L#rYnf^W(@HB<|^(u(( z`(znV;mVM~8taIv@f4P-<|Dc8*QECPf;w(x0t2$gzLVImOJr~DTJ3xt%J9F;P=&0( j0K1`u8ZYht`04Q%$=ecw%=#>#00000NkvXXu0mjf>&ng1 delta 1086 zcmV-E1i|~y2g?YM9De~few{=B001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchC6Jt#ZL|;22HBAr3@1VbZ19HsHdX8<*R-IDc0vQn=I^0)`a1gkTa< zL^imxi#>6j2o@L{j9o0}(iqN-acAWUhu~oOy*In7-IY#~?c}>#?aZ6^y`PykGYiZ> zK>x~3^{G7sTsN)c=2<>$KoL3U;w`@{CJlorsvn48ima5hI-h8L43!sD=P@W_msxIu z8`SD^@7`F!Qh)uCG)9rWJEXatW~w{SSK)*p^H`dv5JfTr9y)vFO6)4o%Qn0gu-8!q zRY0hfg-;^iibjbFH+GimOFbyNN~1L0!fedm;T)yJfxVqe$zg(yknMnio~E z%+tl987XkYrVwaY7Txp)Jw@SYEn*4DHe-$$WLGrE#(!4QDOUc>&4*5!g;`T02y=Za zub}gS6EH#iV2t-xvP-5^hz6EFJ)qWtuJl5#W}=EgySN&=3R|sEacH__Yg;Q`;Ux#{ zHVso{{fw79wr8kyfNJk7A6Is19Hyq?B~63&QL1#QUacRJtb+4x#Ru0PL&Kz3;ROOZ z&oCMpt$*}+Mzyyk@6p)RyxECU(!CA4qjZQjE;SruJ7*rLwERQHBvrz@Oi~9(R7_I2 z%Qg<3Db9C%Nk>U}S+zJ~FK*|*1WnLWRDasAZqYZ{=cCIF9QHyqw_?ivuEx@@e|d0f z$3*G(sZblRdRiW+^)*uZZ1;Y6s#b&5JlmvNu=zvKt~X%!s&HA-C!T$-!3Ix7*CNx& zoKUPwZ?^rl{lnfN5$biH*zL%_)vO9z#Am41*(T#+9H9iAs5HL>j(dFYSsEu{+BX;S zti=NVU*YTmCb7tK^VrLPIkH*&4)$2%Kia29LQAur6b z`^-DfZ)V=f1eik1dJ`n|4u9}3Krz(+; zRu4x`gXM_Px}PMd2iu+ot2kO7co~OxV6T>4@cz>*>-NXM2Yc9%Xx-_i}0 z_I;}5DouU?rr6p_$^4+*1@7(pu%F9kzWueUhOeV2%N-PYWiP|xd*~v+Xi2o(yxEPj z-cbqutF9Z{!zJM6MLJ%!Xzt3&$SqM4#_Nn&i`Nxk36_glQIuI$h|3=TE?tsy$F=kX zj;}LRvqO{?jY~ITDJvtlP>{yU`YmEs4UhEhY&A!)W+ZN%6iPm!rOj&9OIS{bf}dt7 zt5}X%*u;Rfq<2RYt`D=$c{ZGFl3Bd2sN$;SX#pMMvYf1IAZr$<8gBTiPwG7^N!GzN zl&e|RCz_`t>7+K*ewlhvYRqCkG4C4ILc~&5v8-9->9Aeu<5Hgu>jRbcR6lqP{?yfHFMYaJBt_hEV18nOB3gm683&FTr+uuz%p&8cwe$ z$M^KBSC`oZWP^uSX!1Fss_8~rE_Lsnk6(_6!~Ka2D|u51EZMRVtbcZ8L*G$jBYj7u pqOm_Q3;juwD&tco31_nZl)n#^plcGw;?w{D002ovPDHLkV1mZKQVak9 literal 758 zcmV{WTwx<@BOHRbXlY>#7J?RIIOHIRse}WI#RCfuC0NLn%US4&5Z~-(Hp%YZT|PF+ z%s1crG4H)BFo7Qb2>F;o$i-!(Q2-1v)hX~fQHhQi5_cIaIHDxCBB7>+?K01V}Tb>SEo(ZFj&?=WnQj7d{;DK{1 zF*6XG#X&t;W=R=U_$|(%`RohUf#F>E54l&WXP9dK-RBWx7+)>&+7rW&y`I2I1v}hI zpIJ*)Nsi30Qwx-p+tvW5MRXNU@DrBBOOe|1sj#M0eT&0|U||v~WbdNocpOn-sLD$% zh*iay7|%d7m#d1@c0dO5cf>Hk$iAC3KddOCPr`Be;{_f~e~~qfZJnAck9n` z%(0DS;(vSQr@L+F=S~C9n)itRNS|M1{LuD*CPn_YeNacKVFx&WzqW>3{fne9huFg% z&?D0K5-5!D=6MheMl|+Iaze0)Sakzt8{A1QE>QDIK6Zika-)1bIF(dJP%OeWM35J& zj;AxRHkD(k+Jiot$dg#~v+HQnSQc<|4eE8-L7}$-oIKd~@wp$M(NwXvHfVY2F{Sll zOg4kT0L)$i>(^m6s3v-kYJAp~(pA~BK5)i%q1m=W8`clWvx5uW??323HldKb0Wvst oBBn4FQhi_Ar15V*mgE07*qoM6N<$g13`hJpcdz diff --git a/docs/html/img152.png b/docs/html/img152.png index f241006d2a5a78e572d8af0521ca02d9e6f961d4..a4fcfdb60fe15e4779db9f32c1ef328e22f96be7 100644 GIT binary patch delta 790 zcmV+x1L^$h2Bij&9De}q)OS7r001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCV#3f?T)w=d!ghGG{mVkXwVkrCNC(#@3LUcW5cuKK5TsLA<;xUN@#Fa{hJ{kcS!4?_4J8qMlI{_oN%oJ*mB;_84s~zr^%! z$l+;dJuuO@d<&RrT{kh5%k49kCT&d2k@%xkAb*$3(MwR}97_)13LmQv>Gv-_=4r*2 zH2NC{$|rvCOH41{O^!#JGF8q#iMSQ1Rbfh;JvK$P>3V`)+lx}IaE=m%#{H@3(`$UW zz?VI?A3xf&b)cdD(ylC3mmlmt-|C3zubsYYyE0?mmiLx7kN&g%k&Sy=f`9iP&m+Rh UXAiT(-2eap07*qoM6N<$f_|=pBme*a delta 860 zcmV-i1Ec(<2I~fp9Df0t(?_TP001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCcFY8RfT$_R}Sj914KKg`ZU8Jyhhk==^ou00W2m&`ZOG~ zUbtSF=zm{sMjx;G)P8aeBs^NFLDirP=A@@aT^VDwU@c5hA3nUekAwUE1vQ${p<$#p z9qKYOzW}>74yzP3;ncLkV&Oj4RwiKF2zKP23M<>=fHm_QxV2q`dj)t|%;V=WK2uAM zdBFLr<~@qkL>qTNe`0?g1e{gm=D%s(s#aw`?tcP5cpaIovy)KWL+8BRewAq9Ch!JJ za}Hv+3%Z^8)2SF?zS=x3@l%z+!NQ*&4hHOUXfF_^a$R-dGzaHFzF$Qg+DNZb~B8#(+d91)#m;_FBZcpONatozPF^4lJ=^6?JI(}h`mW_s=s%op={TUfno@bPv mn~~z{e+qOAv0CA5d-w}ERIgR zHlQU13Ayy3R9MiIKr7@DiJ%uR_E>~g#6#<$t-bY9MG%ovw1T%N6uda^O|nTgsR^a{ zV8XojzVDkaGqc$M|1E-67obp6CO!kBE3K$(n_4$9;mfDGA?a>Ynv%BKEZ?q{>!3{i zxBpzMHG26oe^5)E)bU_i1&hF~3q>BR!g}17a%W9_ z6JiHDG94iTvk5CI2_>o)$==6((oLH>%l^s z(l=|-U=`M@S(*mEL43ukOnDEOokGJxx3L99QkH~^Io{9t(KeQP9Nax_S7#K#cRP3- zk6Rwh*ot4TTVj@S7f?rKqQcOtyfDRg4viMIB z-I^&whmMM&5W2)!N|urzYnIncp{C#|P{<&fF%*(5TZOlFsC)P1XW5dPDA2R@^zQC^ z-`#t6l7JkM{I5zx23_>)v1M8wsL=qbK;)_wcD(LRaUhZ?w}@YW3zi~Gr8T~bDcm}P z9EU>62pGXBb8wnUmpxH*uT-2oP>$$yyp&yK7WC|fW|9`lD4S~D3*xm0ws8FU2H_ZB zT5wfh@!avzCDSL==Ho&Iv@?+~K{FB2D~=|3AwiTbOUhXT26{~$wJP3{VJ6AX1viOa z#$p#;nv!f4LOn@(WuPZ!3TsX*r7ZQtltYv*XQCS^PlY>fu-OPTk>8=?lvL+Zl`F$p zSdhLe?2vG*2PUpI>26a2MZ*VlNqM_wG|4EcTvIbrh->Ues#{0OWApRJx}@%vu{}<) zyrefXIB-2p6n1JQl@Z+rV%}5d6nhBAI%Pye74_^OelFtHsAP|=fK;=lnaUWVAW=?u zcWQn?n>fyaoEM}|$(%?<&$e-n?9XU2|5Z@SnsPewPXEST$sF)NEo2?7055<0sf_F| zTZeS~qZVy;uN&K}=6iDNEyHTJ#;}#HhvViuT%0}uwuZ#Qe9Hfb=(a~a)L-oEGW3jx zUBWZgJ>TezIiJ$_p%viu$tuk%1Ki*Z=r22)qg7&v;@4opVEZ&{1YA-%j(fwmZ;)YLMi%}|Wu!EP*Pp6O4@lyjF-zi? z6bb9$Oh$p8=|DB#scW-2j(bGMw(x7%!}pUA?KPdz={8O0noWALnnPmf_odP-#v4Z- z`u#r8YWZkC2Cb!6$ipGA7}~!;Z|-hOpx$0xA_VxN^7sntwy8wSVC<|t0~X1Q#bw^L tz`vx(SN&d6@(Q8;ci7vcSpZWH@E03t#6CexT*CkW002ovPDHLkV1mtao74aR diff --git a/docs/html/img154.png b/docs/html/img154.png index 4aecd5d283cb72148bb2125599a47321e8fe435f..28f2efa46107714dc660ccc4ef6d0e3391921930 100644 GIT binary patch literal 1040 zcmV+r1n>KaP)6{D?bY~#sw1<5;n#Su81*_1q&7?XhOoqd+&QQee-Fj zAl}f)yKl}t_nf|YuLHoI!^rKuHZqRwGhaQbYEp8Cn6})}+@& zlZ+!(v5~-25EG5GDLV8ucVa-jt2^T3B>=?+L(+EP+SS%sLEg4m@`Gv8c?8LQOxr$wc43(-KE+tyYgnz{hH^qJY44u8LJ!N2+} zD&%#@N6_9)W5C7k9|k?Jr~+k%Dg_g$pFv?ZB~ zk?X0mPp)T}(6tU5FeheJW3Dz&Frm1upy4sA2AGF&NM^yvXRLtFA7}@GiNmgjr(oJ} z6;{FM)A4*#8un?f7S1>E>BRZudWN~W$bn$>!MpvvqkOVz@;OeR-hBF8 zv`kz z=k}1LmEkOO6ry~VAmz9kdUIM??}R^=_LKJ~o?&Q59AS4V;;OxmMnlg{LIu>n6U%Ry+m?_h~@#~md zt-qQj0#ZQr43oOdor_;=!CEI|ZEA0UqPECEE*8hUiJ+-k1>bzaM-I`|vL1rE`uv2fEnJ;f$)!Eb3HN9<>hFEQH#}dIo8649 zjwNiZ+O*;^4Ws4``kR0fu^pOK#}l?zJrECR9Oi!iU-ti^3V#9Z<4)z#x~;DO0000< KMNUMnLSTYMJn&58%$gCJGXYzi)7#FyZZ0ecd@OBWJhFtNFI zTYPB=AY`{ynoVW9GVgD08h{B}mDkVAm2`epnTc;reFtlChsTLBcDfcS5x!8qF*qfJ zXshrBVhSB+6({NBg{SR-y#BVBLpyK+S+ra)4h*f|Xy)}TR~QP2Fp)s+&Ca$^3Esd) zg^N+avEb6>3rc|8b9Uev3~*6KdUd+Tmx0JkJPbTU5|NQArAZ-{YTm;g4up`NHIT4_ zqoX3}&J?_iG?uvf0tAr)^qACG<5CA}5$a-P^;<8rbCvFzRUmcE=hUj(Iz4L9zmjA< zXnNZ(=!%^oOI9X{JmTM-wcd*!hU|lAwi-FBWtdi-4$Ia}oFP9H6h|C~I|FN#K%auR zhyC>ouu%mJ7S`q-43BbO2p@)p#szLlMXl~*0~@F?>C=)9OSxOj<9uF-loJ&xOsE$z z)BFM8r`cGyttxY(k%G<@8d<2w_D)z%FU50wIT5IH$`u^tsTKCyp^a++|RULY_3Or5!yaX zTbKNeF#!n)NLZ+f6@?K^E7a0`3Dvd%5y3q8kQe_SvWUh6K>`we2@*tMg}kLgpfBEY ze`fBzGdsH)^(5KMJ?A^$Ip>?XcXt8SXE|q`1g2T;M<#6ETC^2e0ytQeixqqwt3u3j zgX-#7gScVC4WTFICQf2AJE_quO)-F3zuP2pBM zU8CObM(NA9l&WyUa^Gl=Riar^Clz z#!p_sD}Z@e#j6@n1sSUf-%(_~+_JvyXa_90WiYGav2I`o{ORz+r-KgzEddNcwg@@5 z%`@eIf``jJeAGR~>nI1$#(ymf*d5+{o@@>TlR(SXmqXCkm4oq@20&HF5C{keLAb*JPcU;7@v#UFyC98#Zt50JsWIfrcG~SkEf-FdnY(H(HhqXIzm< z<7DP6z6Xo~>>g!48N?DW+x^(%^pZ-+?pt$c3~|Wczh?jMS@XTWSMaL)Nx)ene1EO5 zmHWtLz0g^nZ2#IrUG^91Sf^^NF)V`Rab`9Q6zERK;BNQ|>ex5(qDX&2%i_yk`nS=Q z$;1W27%}&1!HlEs{%jl|Y;TyLXUFmAI5qu32iZ zDL^CqU-?v?avi^JZF5+f?>@WBqX!OI= dx{ZFpe+NyUfLw%>c}D;M002ovPDHLkV1k5rO8Ec) literal 1348 zcmV-K1-tr*P))9!N!xK z=o&8`8^MD)%^?R55!yNVbJz)p(bFyqlEYpq1D+PyK81)YjPao8WsZxNbVd+k0_%JA z(|)#f}}rjtej$&R*b{BZGikc!W-mqz6Lq zL~T2I7Rez1Q>$_~i-Ogmi%&KyE~6$rhRt-YLeJ*@q(o??btz9w(`yQ&F~LVH6XCm3 zX6x#mQmL#Me^%@YY*%Q}_oxIrTq=W4T5R78Y_q{4hl9{zO@J1GARIqOse^qjIA~1s%h1(nnL3saZ4CVl3uBt);+ZzY>ns zB)AZ4o2fiF7kSh_4#WysNF|C!um{qqZNfFxT^x7aCbw5XsZnN9pYt&Rp{Xnu!`UR= zp>|Eq$#(_g_9b3aRXI!4rQF6{ARnu-xjYs(H49+e2it4;jqIUQSH_jRu-lphJOy$zRcaC>&;O3oP z#HQVuzKbsK6{6;*ZIJGn4S4H8oRv>U=IDXP#0sV(%x?o1#nfV&`HgvUs`+~M zW|>)7g;V|6Tn^ayJS+>e63>_Csa9=LLF@k-;eSJ&5dHyYHaU-iHZvXo0000CE+ zJ3I5{cgh5EQ}iqZ8`*7`ah+(xv=6}xg$Os5oHQG! zqnvCuV$-6H-ox;s5@OnEyh0JQ5A#JZmfnSJ7`x@g3%6`_qn??~`Dgb&GqUT~BK6$< zvI1ij0TYu|(4OB%8<&Vlsr7^iOh;_EQorll zs56m~Z5w8zbQLZxG$@O*!GI1S4BX#_n`+}#sboo*ru*UavlCsv8Up3{35r|Hi)yMxLq29t+0GHEnC+MNNNOIcf0=mjUp^RzfhLvHlbY z2*jhJC!k#fU~~MN!(|An{ixAEn?1Q_;TYlcwTcwwX=ODsEfnyjlA{;PImjA}wA;-Q zOhB!ih5yHF4`A3)-iXh;7VOVi!55nj@oXj2R}e}<K3a!v7eF{ao>)nlzZoj){eI z$bn+Xdl*ds<(!1URCZiKaWH&pm`DAgo+gBd literal 1029 zcmV+g1p51lP)3nk$51k3c9gpE?J9=>2#v{^O@jJs zkBX%oh4#l;j=+mNB-+##=?Ur-GfQbZqpclXd$OJDkwGgbY2+l?#4=_QbID$%Y-|A{ z5my~#aSe^8TZuUWRWCXvpmeH)m*(UH)uxd>wN=bdM^Ik!R#8HIqplL%AMWKn4DUJs~Ip#1Mjw;z7!MG-kL6LttDUq1b zb#&sVV&;H(3>&MbSYZQ&44Fb|Rf%aqOb(S-6h<#pMwvAiQ*;XZ_0lP;pd*6jjpxA# z;VHlM64y3JT|crej&kOPV?-{ZG#XYylm3XKQW*FxQuZL8WI4EsC9`;g-YY&djm2Rc zcaY-Xuqh7KYq4bgNx9#0q{?$hscx7;RRygM_MyV0Ve`&#R7+mOu^Hd&bU}Kp=cS7L z$#*sc{F5HS@;JMRzB9nhbL7yR;u_;Kwdu`_oOyibCU57&&aEjv7gARzRNms=9=1?f zpHA(jiq{h!zd4MdGv3A4bicXjYVZ?!9Mhk&T0?pF60rIBDpFNc)(@{7_Ig6!ygT}&sR~dt)$4kbv}HuIJq}i zHgoVOR4I#vuqQs5tlY&_h^PY2`DWfonI1+W9TCMTWW6Je_2+s5nPg-5S>9#ixBR-Asfzi4EVUC? z!3ln(cjK^%C{!vB_U}eP)2$v;MdmXgsiK=C^?D=9Rmc1+7rS&orw4bcI0!qatwr9I z+SR4ye)u(7I_-9Q;oU)a5c*koNz!}=03{?Zp`e|X2eJ1=P#9z|?AAG@Y;GOi}qW(zb00000NkvXXu0mjf2Q%i2 diff --git a/docs/html/img157.png b/docs/html/img157.png index 28c318222068b8358d8b7087834c94a6b6304c49..34b8379bcc12e2a7d63cd471949c60e1cda6e592 100644 GIT binary patch literal 998 zcmV000mK0{{R3J6&%c0000mP)t-s|Ns90 z008dp?%mzp%*@QYySu8Ys+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001 zbW%=J06^y0W&i*KWJyFpR7i=nS5IiuU=)9*Nt(LuPno;dlY)~K=I%idVe=6Gl-Vwu z8%WteMm^|cC`5EnaAG|acM${+4)mahO~k``aMK~kF7qTZ&_fS92vaC{@xAvYYm&A} z#rkOeeDC|c-~0XYB_Rd)KcS}DOepCsfMTAJ@&#bL{Lh^uuMFH@19jJ%S0@9Ca-q;0 z9}q+m1AAMZp^2u-!4<8<0YfmG-gL)H*C6Vvd0Pj~djXN19D#hCb+OyUif&byYm(!qhAYNx%g~Mlso#kEkkcrEDs`E z$rA`A%BxE@jQdS&Oy9l!4wx2KeiAy3?mWbc-6`J+P3T>gW;q9nP1plvFT)!b%-VMj zCZs)B5y^EpjD{`}Lo((TMbwvuij1tg(xUY`x7F#i(F&RT8%T8+0>=H6?@)mP2wK37 zQy?cn)jJKpA&47V**Q>LhHajwjSISrQ%sF_@w~RvUr-@ zk{Ai5Vu>+8tmd9G{_- zcBs}3U}N;7!Tks-eJ;|(es#8*!a2gpt208K=r>l?evf{#1TDnz-4>y*t`iU*5#2T5 zf(x$1ppzVwad(igGA*FuuG&X}$hrwoi2M6b7EbG`ZNW7W9@_pU+FOcPKHqe%_EF{k z$nivTf>x><#6mcvd1!Nb^U0EPG8DiNF#;w-s~Ztoe~0(Q$$&Yn-G3ii3jF)<2SlAN U5)~Xc!vFvP07*qoM6N<$f|(i01^@s6 literal 1121 zcmV-n1fKheP)Z zY(9u1GcT0te6_tef+WbH&Jka~t!cx1X@Np=vKe^&_yC&Su5u7^Ayx8SSmai^dKr}k zQo=A3p`Tf{Ug1Sjv5aRPKCHJ4(BNpm)$kiQp6v~eR_a8e%2sMExUw?g>L}*1mDdy~ z#;WCWa|p5@4Jb~~O1XPv48XakfrJn#P&1_%VM_)zSc7|kz(@ia-VKH;dOJnUQMvIh zuxEhCE(GJAg!ep(EtOtjrdDjp7KQWG_424GX`afvAh8+D?%k}6%pg5V<`9_9aLoy0 zeQ!E6+s~8W1jT7<+Fo*^ZHxx3*x)1ys;mZ3r#!|V^(JJ8F)s|Pm{p{Mzoiq3ei-Bq z1XuAqn~{V8?PVAvJQ^@rc>LIVnx;mmgFxAQj2}?{*W@!(Sa-0L1Ri>scp3rc# z=lIh&TsEZOO|0tm67dSv(}(ZXP1*odxNc;PQ}c6oQ=n+Y5{E6k=ZrXonOE+NEd8u3 zxP*z%)@ z_tB)L84ib5M9`nL`_>1ftaOgQCpGmjzMYVs4Rk`M>tS6s5qT1*>bEmn+BlAYbCdNw z!lxmN67o<4Z)gXLK-V5AKN&CC#fk)rCf!ZRx=m`>Q_FNJ`NUalYh~qm n4WZdvGl&Bs5eOTG9Y96l@_xVq$2pGKNHpE9lUK#K!mL&F<~r-R>!g zAGgfTH{W~nzMY$8061}UlukZp0w{U{QO4Jsu=)B6bWC|V_ghLU;iv&dh=5fXWdk)b5Pjn?^X zQB)?>9$*s6C3vCnrojC&q--TaE>uPMdVk?&QJ{r{3u7T25=ikNaTSG6=7v(jalt=Ws6+Q z2iK}B#s(ZiwVLn5zZ4)r@`b+~5cn>)r_tsSobK3ySWTWmp2r&??${ca-Y*k;GJ z>$uEiUtMq=!^WlW(;mm#zIl@!lgL+Ygkx5RYi7Qw<8rLySEgBFnPZDA$mvvCW5j@- zyOGSX@)Nd;s;vs@arJqv;aJ7Th?v2{0Ewa;tFkJC*Eq6f=1CKFyzh0aHgUY-OzGN^ zYfQjzb+@5Z;X3q~$sDVv;g_M>rl8JQm#YoOCT^8J@#YdD-qC)?CRe2zypQ{6&{fHr znJ0}{5s%|NrPu4&jEWZf7##_jV~Z@v>F~{!-oc>$rRDc9ehlIg7(dp2k9@XdbE;5K zx2)G|kL$|r=!=^2r3QsU0kV1?-wa#x6h_=|r6&G52@$|kT^7TkLW1{jVOBIk-B3{y z%EdftsJ^q{rU2L(`DBP()T3nH=&|Dx(lnA@pXDhXTf%~zE{8|p6di*vLQZ&p(PFTTIT{JA_Vmf1{h$9969JD8e*j+;Yf_|xZFc|w N002ovPDHLkV1kg|_cj0k literal 1209 zcmV;q1V;ObP){I?apLFz$gS-i>w$XVtovlz#bz4 zws8KyUtvPJuwci+nL5!8+;^JlPnGbJP9$DGI-$iV01;rG z{Bj-Yde_d|bxd1sZ4{coMZm*M_)O|qc80bIL?a@x&*5SSEF}gZ7}NVI;(8C@<{jdw z@gu$ljB&>ReSyn6~S`>))6NJ4WSAR-yel)NduONO2H7uu- zU7GhBvJ6M+wGr_S^$I%k%rV1jTonz2ej-RZdY{an-QDxNFzK}vElH(TLli<^%Ty9zfe zPLiF88Mjnf2IZx+#(rPuMmNMFBEB$&%Z0h}ScKb!#=#}*jl0{BPx$cu_{KdC-s#-F z^;#Z3?yvVhcs};v<9`CU5tBLiANl;7ffK(9e-kyolfZ+$9>5dS+#UxRlIE4?(v{p+ z1vLDQByzsp%*FDz0Kx+M?j{a4ayoi*hh(w(c(Nf2aWBsANjpwfMT%=(zw|(-r87~% z!RK%aw*Y@xAz=pUrWfYIR|m5|Q(=zv#_m=A4B(M;MP(~7y07yGzjoE1O_BuvUKC%4 zkXTKjtsxJQVyI!sLKy59%7W>%bS5e|oSl;KL;3_+F5zG33qq&@?sy-1CJj6aTOlpd zHTJXo%qS;pYZ6Wir-g`h$jwJ`T)2WO61JW^o_w|i$MFdK zu6FmkvO-`j-mZ}9Kre~42MHl!5^@&w$Rl&@Zif%0Pr1pUl^ki zysxpE{`R{YV?;+cJI0&vpoeJKOk1QiRxpkw7T6tJUsomlsn(Ibwg1x;G&^{{iNkl4tNQ Xa|$OU_OVe100000NkvXXu0mjfJ-;_% diff --git a/docs/html/img159.png b/docs/html/img159.png index 73fe83b67b58ea611fa9a759900c012d770a0b81..5f6e35bb63aa4d0082b01a9b493b225450bbbfeb 100644 GIT binary patch literal 1012 zcmVF)%Bsw@)T3(`yog{<|Jb1Gp=+gJS-^}dH>^ifN zy}N_o_rA~jzR$DY4zR2F$0L1Bvo$rn7E_(Goe;%~+5^R(fF4-N zgV0=mwlitgld}_|?4Buq0>Qn!h{i-=0n*%18gl75+@j>o!O0U>6!b0)-MR5zxELt1 zIim9ixr+siROF8o8LfrR;K{5Iee z^)Q>wSfa4MmR4*fd)7yk5hTjWUo?rBWJOyhs-L6VmE@T~Q3NuHOFyufMq8%|9xL20 zIz*|{U8CYBbz*Q^5iN0000!pL*Va_^+_U#_oYZ9<_3wmhoI%tMm$g=lREQ6qyXEx**81}q|cP?8|tAH!d@jcdRlDXGTR)~Y1a zWa$4oqRiz9T2k7f;1?s~bBe*R){MmNkqh6~3*j`K+7wP780`#A_H1&F)>;5nn8O|& zJ5q`^LM%^Iar*X%+Tm9S@;)4(LM00kb(T^gbmDQxQ6k?H(_GiGZIe5xR1bEAfl`)a z)V{9Lo8uy=TZfXI;O{!r0BGcITir?Wr7R@V$JPp8qx?{5Di=dm(edyWjg8bNZ!K|l z?0?xL_7eVGw(&=&4MnG_T_$mE3Y1s1jfvZwMxm(tDoyrz7A;wo?opF#89Go7-AqQE zT&rkQghL$}YdBOYamPY;?2$|DT{bI_m)Jc_KUS6CenC&KpHZb}>GA4Mq@_@cMevM# ziA5rmNDPwD6R%WhLo){)V=`*>)1gGrMashwJzjZ>LsVdzm~d62(3go=Zlzy5;RI{R!=~BM>YKpJ(pPdk8#%NXc{n+{rZQ`wh)QV_b#+c`U zn=+~2J*_Rwoh;&|4{;uNqF`FyOK|EmH+&&2XV;>`;hrc2uB5cFN<3E4+7#8pP2jmd z9VCl-w6k~RfemAK^Ra^)foL&zaOd;$`0K0pQ9XA7t;@1;PiOb(%&WbDo4wcRq)Xin z4eHxZ(nU_~AwHhRd#J8pUA{(Vuz9VofpMZPxvvP(y3G;qD{Onc1YqV#>sF8_*;`NV z6RfoV0rl7y^KTYyx@F&`uxL$i7gs=El`4uyHV}wN_zv?SuIBK7j>5b8&C<^nz4ZFQ z4MAt5!Ug}Xr}mn~Kk_Qw6(WopMpW4&Q4uJ#C#F1%%;TlFz>(SL`dcLJYbUKa(5+|NnRI-rc=>_sp3yyLaziwQAMOnKR4E z$~rnaQd3hyLPDIKosEo)6crT(1O$5dOcH?_8B2ovf*Bm1-ADs+Y&=~YLpWw8Cn$&( z_;~6vUvxBO+NW?UQPSBY;*p@UWk=G!10OsXm*g>>Zd7GcI6L*gmaB{&#)bwQMg|NF YX$o9Pm0t04fCe#my85}Sb4q9e06ic*b^rhX delta 181 zcmdnZc!Y6+cs(x*GXn$T_d_RdGB7ac2Ka=y{{R1f=FFMp<>jHFq3_$Ilsw`;(n#kbk>gTe~DWM4f{lGu` diff --git a/docs/html/img160.png b/docs/html/img160.png index 4258bbd4efd81473c8d1651e4babfc089b4197c2..a08696b3bdc42bfd8c65a3d6a763f34307179fc1 100644 GIT binary patch delta 306 zcmV-20nPsP0>A>07k?cD0{{R3#idw&0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HzDYzu zR49>SU>E?vhgCEdt7r$h0LSvOMH#P~*ee)3KuiXYN(Z25aDR_N6@w5%s1HL2h{jj2@4u)eOCSQSv0mz8Y468YS(vN`}fK12G0FWTd1BT~32@Wg|STBH> zfe_m`53nC#R48CQz|jC=Dl#xl0E%*Nt5V>JRA4$;M1& delta 359 zcmV-t0hs>40`&rr7k?fE0{{R4G&UMW0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*H^GQTO zR49>SU;qMs5g?Jo00+`63=9eh49I{dfCY)S8w56>C`e%V_kTZ#fq{`@YbS#N!v_Tv zNr(mpG=Na^KtX|rm6?g@1K1!2h6YA-wWNarOpDkKJYjI>5a)9PvM)ShP?*5TSMLCH zGB-m(LBf{<3=DiARR#ti@*fau@}l~YG_V^E$k5!1F2FdWU+q(sF5@qTiTpGB)fk-m z1%RR-7BX~m9AIGh@Q`=Q-B}FXTnij007ZEpFg#-YkihqWS%IOJA&C0}*aWT>O%7Zg z4vZ4o4xA^O9N6^#I{-z~A;z~e9AjX=K(1G50d`{n8vwiGQjhVB^W6Xd002ovPDHLk FV1lB`jg9~S diff --git a/docs/html/img161.png b/docs/html/img161.png index e3a508d59a5ccfb00762e81ee1ef0b5c900f0345..6b888150f47be6fa9ea4e2a9ab0420b7125da451 100644 GIT binary patch delta 384 zcmV-`0e}9l1C9fb7k?iF0{{R3Kmik@0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*I3`s;m zR49?{kUdMoP!vE9=BufpO0jzuCmqtsfJ^!Vgmfr43Q}-XTz?!N)M5pN`~vOZrh}V< zOK@_`FDQQ(L938ymyj*fFFZW*f8*x}4p~-`*OJNps^ji4$iXdm_6h|3* zYYEn23@QG+oiR1?+0rgS>d)yUUd5J?AC`{NvSI*TqPTYMhJk*LQ{a{ip-1aL_w^<$ zB{`AbW_ZfTPIu{-#d4QHYR(e{l9Sa3P{N5l3iIBFY27V$0}$TBhY(f4a*BBHMMpYWN>5{u?0)TEJ|5GNPx)9Jq>J;hZaUeDc)dXZXrlgiJuun^!h#?bHBjC&6R4tH+A!y^Uj3F9CbTcrRxBvl? zJ&zd5LBuQ!8RiQNj}(B!HB1*wU^&phv4L#^h74B%(^dzrrI`W<3HNhlAc~2BL6Ct@ pNdbq~Y;pOSWo-j4sZoFx003!s9~l5X#9{yd002ovPDHLkV1lTKTHF8t delta 290 zcmV+-0p0%o0k8s)7k?fE0{{R408iUm0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*Hu1Q2e zR49>SV88)1ftVdx-~$5#*9Hd^HM_xJ1B%!Jh8Av!h8wc0`0JwTYFV_%~d;kCd07*qoM6N<$f(mhR#{d8T diff --git a/docs/html/img163.png b/docs/html/img163.png index 2d35de54e27b200635cfcfb5163c318220c74a61..50f198fd1918ce2c3d5687aea5139e950f90f2df 100644 GIT binary patch literal 797 zcmV+&1LFLNP)Rd80000mP)t-s|Ns90 z008dp?%mzp%*@QYySu8Ys+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001 zbW%=J06^y0W&i*Jn@L1LR9J=Wmd|U`U>L_Al63i{wH}0Bga``rpk(MFh==My3W7#T zU``Lyfn`jgC&8V9-Np_B%Vch#hoW{0dI%zVlc)$H9z-t+9(EB0kNpRH^ZrP>G;K-R z1R49%^1gZA_WQ}3_kEtc06W?~YDlc7fSn@8^*OtCIR7U{Zmv05aHf}KHw%vW8nuTq zSf3VZt@Js-BEjUjQNgG z=~mIJCA6LlM<*UJYw5|&hcGrX1;SUby;?%*iL`{YFes)}!;NQMUe@N|h3G)OTGG8* zg6qj}bm=x}sr3W+Q`X>=Ws+Lb+Vb1I2~|Mxudq>BEpF zM6G{|+EEh@09VJgq%o*_nO*$$eEoS#gVEwxE_}yG0vj()8`1@ zI^-xPXI*SsWx~muij9L4Njbu*^*mS~u7C$SIODLpo{Td>Ip}jI;D{~{>w4#NyA0!c zvggM3!CinWK4(_3rI8~MoRhGWa39cpJvj>E+XcqCUumwu*@*on&DbRPJ~roZd&W=> zuL%Gf)rdSjP4m=^%`qZ4SQ}FjbqBiDoxYOIE*yxcqbz7ZeAU`cH(oEe3LSRnfZG0E b*!KDdOVQr_Abty500000NkvXXu0mjf%uak( literal 915 zcmV;E18n?>P)X0w^>W?L2u zezG%@KlA?k^XJb@7ND=-s9vE~)G9}H9g)s37a;LAs9-Clc=rjQ)P5thxXGj#kM3rv ztuUso0wK(8PE$?|a-mGf)nGUeazY{Rst=6v&9HY!4VFEVH+q5!jy86vnPHPwS%tc_ z2SnF0O%3L0Fyr&C@6?q#Ni+P~3n`ph2fgB$5W*o+_*oh=7B_qo!9ejSI{-RXO5t~)E#|Oz1?MsCxFrH!LZa)b6v1on2=+TZJR)JoEHo~;Tv+2 zzF`SszX+wG{5LTle$|TeP^upM%YE_m>q%}OH= z!=^$Vuoy-qFxBQ^(W25*M1e%yUUo1{rN}VgNn`Cv5dWpWkj`Z(U$1>dGc!3o0-A{h zA4Wg}nllob`v8@Tqe+2U-pR0cG|+E0=zUsq!o%uX^+82*Zvej(nC#XYwCIR>+rbqr z)B+uj!L=PnENi!M?d_1luxiAjyxIhK41WT2hQdcs15WW~w{u8N=QJ-%OK==+mVS&^ zCw%G93-L-AzPRp4;(qH|7~Zko6v|5bn;At{U`0+KMDb&qDJr9hODg^zapip4%#j!Q zG{lW)F#E!eX;5QpHk0Pmlfy!JDc@+XXi@r>JY}U#M4Ahr3pSb_GtB+7N$mWr--{4u6|$<8AE@zmX@OY(*Jj<^bX8r`;7 zph!$X4?!Ry-`Xfu&}1PdwEp8ui?$5O?>&rCbHAX5(As-Lxr<=|{Zq-~N^Pm>U&tp( WW_x<*&Gb0{0000#Th delta 662 zcmV;H0%`r(1f~U$9Df1CkUFRU001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCz zu}>Q@6vp2j>ESd^F8l?tZi-YVMYd#6%?|QY54fMcl~H z;kv*;2O}|LV2GgV)T$X68Lq0-c7i@T+;L|(2NE*yN%7hK-tYPBvtxjSIE^YFMHz-n zJmy7l5XXQju2f7x?RuhGyb_E$RFfPsKk6XoA1<@K8x5m+9n$GAo?Vyw4)mf~j_U@o z0X#6rWQ!)lD1T2;L}`~!(`_~WX5tdcCONn2dOs-oT3<|0`r}cb@$wZIYT#4+wMQG? z>lT<{Ee=MKc2)(;O4xM&x#|2+rm0m^$1joZ)M{n>B7a_!VDRFDvh#tbr5V(8woCM5 zn|k|UOWN^=HoY~!suBjCgr%jeS_RrHv{aXfbMoznAAd|jfP>){aU7QLM*#5jw5m3& zg&d-zOp|^!zfOLol2R+#8dhIhyPME16|^=%yI#+<;VYKqY#WtpXzhD19&a1kZEp{P zwpY)$d#A0le#VAoKeUC^X1kwNdoX)vYi{hTQT7S2#?J7{(f9_4gNh2(m^AwvrlF4izyb~!i;JOwEE5jEP2d^nCU7pDzJW3ml6yE0 zP-a5Fb|9@vQ8;`C(xH@?!14ghq9i02Ffed7Q(^*l0RuzQWlBt722v~=C{0mZ=@grg zhH3)S1fosY08iE2NG33MIG`)^sB{1&-dT~=#2CxG$^fc~V|m#k293-F29`?<4Zy^E z%;LZtpiBn{1mHG+r2}jLNK##LEhbID&w6hXR;}YMR6FB3OaJ zF*E?2c=-*Gl`;xq0+0zSAtpdIt!BuTRbU7NIqCregCAIG&lw=V;|r)GpqieuE9eC< zC<3Dglz3+m;R%ot;D7*YI>3Iw-+^0!fqiN^IPq>rQ;I05k(toQ0BhP-rN9w74Jf3- z08YFHXeJ=aIAkWshz5uzeq*2(6FknvX#x!R;n7T#39S1FrEY?5AP5j8H3cSsN^16G zFq5egJ*0^;0aQ|N;xYg+HJPrGV*)VUvK(M-05M}3y2&vCm~Pn{SPwvoyAEP)#Z+B%(Gn*?X#WFawW5=qTwF3M zqB!YRMI6MTD!7Q)!BxoMro-VRh*$@9R(z6I{u;y|Xv-qAg>?>~vJa`RTGEgXk4oK6e8xZsL`AlQofZP--+f1|P zg%RjIRhji{vA{rOTNLI@+@{0zePwh^ zV4$ZjmVi>I#_T}WV+!oEJ-86}CYI>0J_T{uKgmS{rDS7m{AH#D^{uUGxo}ZCy;wnl zRFP|vJ_4&BI%q6*?IACMX0q_8Rlc6|1aCEAp0LCeoU{LL*LF3 t0%J`9*lsi5Ubwx4n+x(Y0iW9m`vlU(itmRtOxged002ovPDHLkV1j)~CPx4O diff --git a/docs/html/img166.png b/docs/html/img166.png index cbcd172629a6c66045b415b0ecdd4109eef8c923..1f5a59e6b4b9ea8f3de8dc583b243fea86111d43 100644 GIT binary patch delta 191 zcmV;w06_oS0nP!C7k?cD0{{R3Rkk6q0000jP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{AwD*Vm;e9(0d!JMQvg8b*k%9#08dFoK~xx( zV_={*V4A)q#{kUYWH`a+z!U&vu`oPkU|Tp3-|joXz-L1O@;tl^LPC4`z}80000Hik0G}lLYg9hdXS`;uK;?3Z;#K_=mFtFAHM0OJ zzd-`oqNUR}pvbb{%tqlF++bjuz9k3Z*W@0~155!xMh6H08C)AU3XoK5Fq~rGWH`a+ z09F*Roq>Th07;rJfUALlB@_t2qHUpf7+64lfha-`AVUV;2?*6JQ$yDPLlNc|mIn+B zGeC~oa|Q^23St-xk>Z1cfuSGh_yf!kMVt#5*mRMj%Z8x?i8q;nA(0`QtAPWeh#Tl7 zZ)BHnWHul;Q4$R72U};SFP#KY#0ghXIgqU{Yc@z`&rubqiTB2T4Zb1x!$y5lZtiK)lYx4HZ!EW#9r* z4;U1{Tuumekg0a&2TtlagKTgcO0%Mgb3y6f5Q=wU1BBr@0YZB-2!ce|HZVX06#T&y z6FVg#{U~vZ?U`T;9I6%Wb!vRDx7O?6FB`AP(e!y_sTJpR!tUx*% zUmL&jgQ#4_-^iiL$)ivKW_(go0>upj#}kIVNbxB2b4RasB#JDo>`vweHJ%~^=3Wx&$ XLsc#;=ziLL00000NkvXXu0mjf(;1&5 diff --git a/docs/html/img168.png b/docs/html/img168.png index e803c83496e7973d6cae4b1d447a187c73fcbd6d..bf3174bf10047e1eb3fdc4773d63b2ff22b035b7 100644 GIT binary patch delta 2014 zcmV<42O;>B6XXw&9De}11Qay@001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCd29;&t=t*C7yq#(6Lp)WoEcg|gB^=h#Nf0*RI-}(M+ z&Yin_M0d+xx@(#4s%crDzaqHSU6h}Y4HUx;OurbUC9P1LKIOWxFT#rzEHPD^Q&+}B zuj6ex6 z!9)ArPV8Es=?_z-i_s^ZC<*%SP2Anif3;)%Cg~%ehbA64J!+FS*kzG^VY97*pFSpj zX9oHj$O4O&$$pU(S%_`9D&uE4< zvq0(LnVI0k`ehoTRBzm3Z&Xd(A|lr;9Hs#>upRTw*n~VFU9_iPrAZOhnrW~&PfzxN zEEp$gmVavXEZtD~drZUTT-psfB70D9O3gVxyIne9Fdf}ULq@Ix>>S+;WhbXTJLmy6 z&*olVptwni>Ih66Jrl}KPJMRJ zCBD1CKj=jg9dh~u-K7(Yr0XBgDvzOSm(|3neKs5sdxngC!_LG-OuQ$T%gEnx+G2)L zbSGXi=uJ!y^B?0}ZiVc@gQe|J|G@yx-AD)-xejB7)3cYIocipbOSb8majn36EUYz~ zUVmOP@q$c}j4}3R$vrN9tR~i)d*O)V-zfGVPn_^3-V3gdip)q{cP7^Uq?7*5lzXgt zP_U-9-PqnWwT#1o=-!_vms z+p4mpht<{ekO`;NjEQakip#`{?!>Jbt$&~wbEwD+?FxR!s|BHv{<83sr*7V;JbtCK zWe>o+DOm)S4DGyxz+gJMk72SM+7x~N-*Y*jDAU7 zw+J6O-j5xJ$=JDCoYfz!`h=!6H8plkrXM5yIA2gY1>v|Yu9p4cJbMKJ6C7;(y?^RE zJAQN>Y3GLp;q4<}Ea`h^Khf)1($0458Ybf*o_ORV6S* zW-uMyNC+9Z4zTCe+SJt4B(o!$=Rkexyp@q%3V8a-{%xzb^*W^Bxs zf~i^$K?@xxCYbuyb_pS7m8G)z=&@RLyy&{%`mFRc7qCStr$1YS?^t&vEs? zo;v&hKUiNsAxq(f$T7PrxB6;Csu3-iC!SMx5x?o*`)>5rp1*3XMx~ZMlhqZ>6Q|9( ztN2WNl#FlXTk%Dfa9Bclc7J^q@{muEVF{N79%wfMrw=&cEXc5?16?Ob1q=ENi#1Gi zth*?6pqAVbO8zuNzCeaJ7y=FiDW}h4{U(D_;*s)_(Hm*vAKbGj??@=Nc0Pc5Ai2R1q=ENi!~rRqZOs5^d7Yb_E@+K@iGJ)2!B$_ST6zyiATyy zj&5{&*0RP-n1PAK%cgjvg*@a6GVT~qW_+g|3o>Xr*tq)!&iV|*8W4RGGrwm<3kNd9 z%MfrNNU1f}ivV(eN?y_yfNPp0a0IL2XPpmg;H=Ve=E8&QYkcV7BMvb9MWhSu4YTEF`y8IEa zJ_E64ufM38xInwuv3!9HaWDiNS861w7Xjq{l)Mz_td2L+;$E%bPMmWlhCBp8Mt+qT zBPW#^H8JBX$oMAqQ?bv`XIQKOk^D*x-%rK;C9hk)K!!LN0)Gw!DYeLY5kT%w$xG3$ zT!)^2^FoJ-yvJ=v!r3|rc}NN}kY8B(5vx*}>AHn)o^cjrSksXjQGm)Usn4)j!$dY$ zsS*64wL6IBt@8&m#K917AV@idPOSzgB_1g+r6WBc$5)cR+&l6XeDcsr|7u$hj|Hm+ zsO0D~p57BsYFA9u$oc~TDWOLSQvO0-F^EBPtB-aER_Up)3?5afDI4fsFDhh>_LNzN wRgz!I;E|P@vVo2uRUvD{H;MnT)p}d}2S}om$6M^!`Tzg`07*qoM6N<$f)bt6vH$=8 delta 2450 zcmV;D32pY|50n#-9Df1L10Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchC@Z}|qbnbR?>rX_N&4!eA*XL{ zdfZMh2O0QGli`5*K2)Q-F+;vTE@FgD;!O=?hnRSc%s)>~b5fa$1-2EEX)30iZ$Y`7 znt^f9oZ)c-0jZ4b&npyzr&b;cKA?mht-;3WYy&LOFMpa@iSuYf%fn^cdl+((=*aW( zbdR;FkuYba;wk_qwl+c((LFyyxNO6-Hy*O{U4VwMfPNY1Syjl(tmFbOsA+kyVRHed zk#B|zgVH`Nvm7N_1sZ6o`~-!^b?k3|fD;`Vi!(#O&TapH@`T#c;e+NiUxHxKn@NuLoA!Cwdn`Oyzv8?>_Z6SQ0R!1(2 zm){7|S+!V>jIbQaW!bfu}4lWWmJ<7Z@5LZnRvYX^;{naza8W zYg$NN;KC%!2HJ9;uT~B;?*bN41Y~SArIdJXQM*_NJqJbh0*{isx+KIala~j z94SY$)~$0YivZUfR2eg$O?(bbsdkk?$HoRa7>012_EWY)YD%T8wir|0l#QqTZm3X6 zWsGV!-$nc`awg=^4)3bVgq_4uJ<2oE(b-^BL6qg72D%tSM@=$^Y86wWPE<*I41Z*` zi7}fX1FXYV9>s*{Y+%jAm^Wb6QxQqgq3*%Jm{F0Bb<}qCfk&2+!^}fXjLX?DSYxT< z8xudCzpLt7*nl7L3_a;oajR{h(<)t!SO2S^PT8UII@%b*n4VC~ zlE4fEdv$BFskuOoES5BsSO-@V6Mx%Rda&!=Op#fVQBnD^3Z!ARtQH|V(1P1)wt$LT zQa)7epTIg)LM35@DDyJBo*IV7qn*HUpEsr9XkS%7rpWY5YK(3L zuw1X3#PstRTL_7xrVEhM40D{9$5z(_?40ha7+J1w6>3@|n`HS(v$69@>w|@^0PJm&hlNrZ2I$%7mDuu(HJ~eY{C?#@i6T!pOc$z-w z!eE0rT{35_gC4jYyQ2^!#;nGLo0z3rx;X@JQk4zW-ctb#>FKE&;8+5_%uU%iU-Vb&S zta>J%b1H6}UL{GbPJiKBWj|5-m1LbL^_&VkUX>3zV&vDDagPoi%AwL^ZJB4o=%llr zAx5%ep8W@uor3N+9!jl36^nk)kq_aLCSHFY?f|rg@NIf*9}}@}cT*8}zTxVnZT~q? ztQWxO0=((-5WO;qB6ev|M0hS0vH2*qjDr!=3|>gA_9HI5Hh)TS*;jOHD+8ry>!@i` zc8FGv>+#t{`#{8~KnK9X(tRGvoW^Is*X%xc0DjpDU?q7A`|Jrs@3|Pl!ozsso13zC zexVhx7U^F`t1GLx8gb?829Y7T*J7=UD|l8{yv%8bwRTrTu2ON~#O@NVj(im|AGmxB zO};l$Z;>@tIe(yi0EWG^xs1DjSlP#|KMBoxvf=^Xw+PvB#!h4}k0_+GCX_ zY;JDC;@^8sElsgxR&GESSMZ2Cd5f>e)~%J_{xIG@qcG(VEq>V_B|bfwUqddbA;tvt z;VA3f(LGhDW;XAA>3PU|hk|&O75*QtH5AnmjtMS1g`^P!94f}VH zbU5ve8a=feroG(R#ortTP8FUsX1Gw7rG8zb1^bqWK&FyMI5shUCqTimK1O+ zJP-*2oJmFe0+^^&zmqwm1vTj?uqM1njcz42^eM2N$H*M{hwF;|EG=~Q5b<2#&rhGk zn!u!*HkKaeaDrCTn`Lc}U{82~HRg|~NvwUC^s1schDP1+1Vai|rMYZsel+&taA^JnSnuxA%=nJ6N8-slLYg129^M9%D^`4Z)WgLYhhqm!f=_v^ivz+Axp{Q-)C-Ee>`%8kn8*#KoS zF*0~FFbWW`6vf;PI23T>6THC4ouHsFApt|$z#yZI2-~R!6i8Ffxd4mch5&vIhAvi4 z2#*OECkhM`egZwS;TpP94u*yY0oV*?BF!D-g58*a6zv8?s>78g@T+4Hy7*Ip2zC5? z9~c8J?@(oE{MevvtF1770SF5N1EvBBG#h{j);R~rH-WVQOmWc12+pNt?Zg{_ zRdsT&LLBi%U{xKkogs%I@AwMlwhZ;%;X6!sL4q+fa%pHVrV(J(P!J23`pnS5!1_5- zPl5TuY=-3w6BzIr0agujCrpav0mEklAg_jj;hCYr8mJMtJOWmYZUpB7)(aDWydDOI z6WqmlW)2L@7)C@uxDim*=tgiCFdqv5^5!rwJZC@7F_VFTT>)VPYwr(W^6Up1^#M$Q zRcn_uF<7KE!HodgsRS}mUxE1%lLYg11_oDTSD*o~>Z=UjnI19N!i@lf=pP0w+cF#& zmM~mqVD^EC8DKF14A=x1oY)UA@TDGr`WayXP>%u-GGr>?(#!x49w6pvJplDHCYbJk z-w2>97&w8hC_Mo6Ga2A1gF4eE20PUQFh7$Hd{P@2ywh5ue-QLDZeR?>1pPb;hA034 XG$Ch5Xo$8?00000NkvXXu0mjfZF{&j literal 540 zcmV+%0^|LOP){5d)ICO{009YwlV zzT!DwU`MarREbB~!ZWbJf+N66NCn_2Mp6_Iq%OjM++icts6erAosQM@!(PtE0q&>>h1vlv-TjR_Mf; zdGBD~gNR0+f}s{F);;n@3Ur0000yf001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCNkl91T1P3=EGMgpk#<2r+Q9gN#&U zKvlnzfzNbVY`e1Qp zn0h7$1|=Y6#NdDw{u7jegn`p11_nci4$MeG0$_7kKr>;*ECO=5hGhd@^07*qoM6N<$g83=2OaK4? delta 468 zcmV;_0W1E@1Lgye9Df0uS*{lV001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCR^KY1^x-u#6cGj7k@`|GjSjeZYG48;lg5! z1BnwOk;vkp-(4+fB{sx_#h2@SKl=La?)$Dl3gd3UhXXEs3qMg0VIm|aKlduewo(B) z%`8?np6TJC39u?~Pr(sJG}l5Y{EgfnwHJo%ahmlaw0^%&CFwu|-YOMY7e7Q)q7>-F z=CXISTv%~cgMUP_i|AY*IT(VhYr|M+s=Q#k44Q$WEYXnpaDmEe8NREN=c|D&8zvKq z->y5R>?TB7KQG7i+;%8!HJ5SDe~rdjIyQdcxse&7;487a!X-l3#=5HvL>gmMo1dF_E><*w-+lcuA2O+hi?_jH%2WYm7bFyF*Bp zvJJAYWs3|lE}@ZKmUn#K`^Wvfe>~6mKIeST_j8`-JbxUbg_$AWG59eE1j1)*WMIXz zG}fAevNp(lhKzJ;T4Rmb+)0Z(_pYvp3Qk>R^C?zgytP&5I zT`8qeexmy}P9DkDy8tz60wPZS{*>_Nciy*U%ZCMKm%fTV-Q89UoO2Ke!$9*VWIyu# zcIlR752lCMO;7G9Sj$7~-m6lvD|JWdPmc|{0i!r&?t2|zW_wcSeMY!KDowD)YODvm zJ*eo)ndErsr*iP=glv@;zD0WSGoFHe*~RMXfJH%^NjwhtlBOs++P|DkNdT@Aq9VA@Z60 z>Agc+VN;J4Mzj$6#k#0q$!Q@Ip21DqT-?%?4wty~_(62n2A4XMQnLE94u#K>OPcIv zbGk^7_RT9#)3}9VFb$|SM{gBWsX{agWdlwKOK}lDc11R{Kl&hZ2@y9JtV{I^jD0mv z=68-HgJ-pL7%;9lkj{&3hn}7m=j?cGFdAn{Q)G8(e*)SNwKV87V8j}y-o zSw52Z%Ob!Lwjlrv?aaj{4fQVI-VVR?&FR@Z1z1%FSXnny?+`7pNjQ;!Dt}M7ph{h4 zHSA^JR&5~ed@-@IW{RWYM@-2Ti?S9F;H+NQLKyTJ@@Cy9}IM?xx& zDftyxIPErgLobnvM=z`YU1o-ygAH4917KB9p( z)KYkS&twk=l*=zG!t2b6H5L*Ti^5Bs3`LU7G>+TLhW=>YTcDNCJ_x*$e(Kyui_Vi! zR0nkGk0uhPy@vS;8C9;8`zW4+0*aNr2~qj6lqz~K2QvO=05V}RgYlP&dohK+e%g6*kAtI=uRO{ zPU19uSJ1%Pv(5iQm+NKm{^bg%h0vpb1}$f$O+Fg`eUruAu+v9g(;+K^j>>SdE1g~& zhLaQVleLGzzGe5>$L`n0A290}CVl3~vHp`+xZ>2Rqr$~ci%YmgJty;D)VtOW9jTb@ zTmxrx%*D`dK6rh%VLzz-4fH&@I3w#_NR4F2{m=92l6!A8ymy~~W?v54!1ycG7YU!n z27m7Z2aOnHq!WBLRUh5~D&DR*GcLKb;p**iaIYr|5#TM6u|20-8sQ|B9$c8ZBA1UU zaxa>su>WPE!gs7G!l++IK@iT}166-j7BU=;Kim9+$i@R0ME>TP3e!le{W+zEr9Yuy zv4FvPc7&spBw$mSpIS&!>22W1EwlEf!@!v1@IrUJS$h3V;MeziTF_=gpedsLi2S~a zv+n&Z>rAHCq3vw$uYv!0Z2%_6v4?+sDBxvmQOo~vrqAQQ^h=f4H7fEt2t7~DaiBG-EXST!Lo=xTmS0wrJaI^2$#yO&=mlnbqa(W6=9lH`NJKG_QH_4>#mTHdH-V zGj6KRD>wAs`*2!*Nx}_t=~8;x^rGbOPzOr=bq#Xogl0xdH8O~YU~4Zu?2e8qNf^Q2 z@Clf~6^PU!gG30%AJ3>C5suK86-q2N;3qraL^W$1B9eTL@V~xUAP@WECZK&)Mpb$vGq1au;kK9y-+x)2EFjwqBeOp)L9)kepe9F)zoX~z#<>SY*yc7U+l51n5V0Z7nhjE zj-D);hqw4!JxszY@*%KHKU^5b=*+gTU1efLM`&i+>-D?%l_>n@Lpq&wr%%&{_hwHf zUc1G+7@u^7YaMNBE*&tUQOO`dfct9ZGS;x8R79TsczaV`Y^@+*_jt9A)3DOxkK!k# z3`Y|cF}|<7vv5dgjzvd>@uU#oUXr-;_EigdIXxpga#IaE6jb|qk#b@!=s>;facXO} z9Eu@4oAf!$kNJ7poZw$hC3rUFd&`0| z(a1Z^XHa6!vA^W0er2Wm#NF1E#XgN~iE+=x9Ll~|iNJa6CxmyJ^7WQIIWv~;=Ml)&}>px=eziojEttj^|5)CGpL1Z z;YTEV`t#L2rb009hKm-b{dLsM>)aoh2^$EJ*_~;prBjPCfG2|{y={g3`$^Wfe|hQG z?=GMg8j}VcfCMGy-|KUHnAF7N`a}RNn=ywVtwvsw{uB(czwT9^h{MQcFc8mIo0)t` z9Mx8iEHU3ae+muJ#(PuvJU6QrW}g4I>kFC$L>r9(L(3|J$?j`n^ZZHpl;^9zJuu@k zoGz2#-e2F+EO>B(6r-!x32w?8wup(l10l&0u4M9Hsr&NPX`MKOs*&eXXWwjfcBS36 zcOCFaw=L%jnp{k-IVsr|oro=^9fxIb4J_QRG&ON!OFQIv``A(Qn;skEXyh`!YGy#y HyA}CgLg%jo literal 3108 zcmV+<4BPXGP)wL_t(|ob6qSx`QeX<}!ddGK9h5 z{a{VHIFvVsSf4RgH&5c={&gqJLD@763hDVS6HRcdB~FMk@ z3zM;F@k55TKxNHjd~+ct#_?D}_iVQ(*s2t!B!E*zLzsjd`H0V4=uM}F@qmy{i< z3I4m>IFxF^eGQpZonjt(?0$A5xH(hzcLg?ghYf;b?*P<81bibr8+r?P#P-Y|?-Dr{ z0%Ssz^LSA&vcV=d=XO2^Y7*;-qqKu1EV%N@7E7zx9+V@&r7$nlyMc3GT2O*(hN!(O zOcY-j%9N(8K-CpXyM}M3|C|1mlN1P{yiRh@g7TfwY88l;^a)AkU6OVRF(M6&7f3sB z<)fG@VYwHMDztFK`hEf?YCw72iHr}5qnqC)#JIuNlG}Hrh1n16#tI>>cahX6|LXe? zK(;>$6-|IZ$|Q^;!B7iYz&qTFF*Xz`4eCP<1rO|~yFPT#X3Riuz?8_GukPAAeRh0C z*1C`np`rjhc}B3FgjkTOwIPfwiihji_<^~hxf>P)GlAU=fJdg7%F2D> zghlKi`;=wL6uPg4?vK!nmVDSozeB?IW8uMeT6hIQG8+{jto@c(X>J#buxeN@7_msx zY`mHy!371L3Y$;}K~_%itx&H6&tkD99k!~Ul;}4l5Nag0C&8nWtl0=63_rlk_hzEL zO}Z|dN1sc;bd=B})7YI!V1fH}Hu^`>pt;e`_c9m-s%^Bhto=#1rQ8(GJ9GVv8Qg`5 zn)U9yx5pF5^S&rBb&I>Opebpg91hW_hR{8%b-mPh;rh-n--DMn1 z%S_j69A0S(4b@d4434L$yPCoMVI>D8s3TYGI%zrzua~ZKB?n2KT+w6}$9Jm-AALb0 zMimZEZxlT$<cgQE#y!h?DI0qJg!w^J2`w0hmg_agz8NkJwjMu zcb;+xN+{kL!MkB}MHr0^Ot_)pd$uiy~kq`n#bXpp7PMYoEB zjXndmSA)3KGjb}Z$st8BVu%9i)C+4(IdmvY2xX+hauAI-tZP6_1kyv-rIW*lIUH?# zSVTKmXXY%({USPMr93&*_odBnkjb23MAy}D(93X$LmzNa$tmP12c4awuEC)?t+Z+K3G&p6a`3(u4Tkl81I0?#{PoCamq zn17Dm9!?Ig0?jdw%$#Y3xi62F!_qK}&FZ7(M!t}ezAG*k&^sb;tnqwtqr2o)7Rx=|n%?$aCOY0RAZ7IYx$J5$KAMyBGQEg*4}{PzxWO#b^{aE_DCuSsKuVA?E|U z2%X_VU;X1@JkX*f@&@k7Q0zofe?yvZXc@O@9pQDr@V$>w!#I_$9nDn4ix&0s`+Z;x zxe938GtQ-9ZKHdK3O$tr0x+WItmD`dA|f{mAmor3O%*WYq^9mTq@Dg4v=6J7r}?k) z`>j3oD11RRYipMsr@lZJiN>UucbN0q6p3-E{eiH$1RzEkVzjim2NbS@gH(IVwu=m+ zP4bELSUcJ>DJ8Z)V0{^fv?W|z&Buz%6^1Uf4_oM7Y%cuqP}khp(hV z0fWq0QJ~`bvM=r7D^lCjWd91W3CCSwY{hI(5GRKH{OUV>qOx&dk*@eqLjmm@IUgTPuOP0N{+ z|2CkN#pg_M&>dv9y!r@+$)jbdIS7VB#=9r46T>lhofwY6>jxCM{ml;5W2_zFNw@R^ z*;{+X(?{qBAp8LgfrNBXGXJO?^qP^-&e?e2vfpLH{Ws+h)rZ^NHdK>;v5Q+_IMl_p z91a+)@Y^&i=^X}|PYFzV+6M*oJDoH=JPx|+jkapSID=VWjh>*_SjJWZF`888YNM8Mcou@jC23cG3l-zr)5P=D6 z$s&S-yN$f(_+|0#%4s(cTQb@S#HMUc498$|VmJny z&tM=WAVBC<@~}Fz@~k7L;CjO6@yJn>&F*nMZOhH zFqpyV*|ez~RPSyupdKlJUtgFN`Bs!E2c#A=nHF_WIminJ!8qa5cz1kZR^(gJ54Pzq zihL(FCx&CN*-QBT0onT}Fl@)@`~6NnF(Y5P;$`z?F`LqHQ&vnz&fZe`1q{DXm)>L0 z7Iv9rUP156AsoJ_$}oVAA6JRq8T9e#w!>S#%D3MtP$333PAdX4wlLssRMZ|caBt#5 z0`krX5V^9x0AW!!x7z1{zjWVKAjkj zK|hC~su|?Y6td}dACNt*$858hZz9c|RpkVm)mM0aQk~Q0E<86U5Em;LC>0p!#b!Ev z_aFy8V9-{CI|i5K|J|_TL9j*_B_W4FI7chqDQU(y+IX$A=_iSH3`IMXh~l#mgXkF- zBdlEuJ!>pO~rmaz-ZTNHodPZI4&k#2`) zF@z9?PCPxdv}`8+TxBbRSM6h65^ba7E)$YA&+>5<#r?8>0gjg1$1M-qxM+mlbDnnW zjlo`GP?TWAV0z6==*X54f0AhD;~aN-HfC593F#rH-}rOI;Nxa_cNl!y*kJf>^(Z*f zZDiQ_K=!7W|KNK}axB&uYz>AW-8=;$23XoJy$|&hed}&hBs+``FYeUh^d{!yndEP6 z4>q;kUcFpkHy6Xr_%{q~rKaRE49%_m#Aq9bP602C40AEujDN$>Ruuzf&LzSig-A|e z%r_Ow;X3|}Lt9l0{(?a$A2Yud(ZZl6pH+XA;&&Lv@o!wZSPjEsI#8Ql5%c>ywK)9( yhOM-#qFeP?)sH+sCU2Zu+t?bW{HnvC2>%aYYOmWp3-bE_0000+|9>F!-Me>p@7_Ig=FINhyH~ARHFM_7 zva+&{j*isS)R2%6XJ=Htngjl|*y*qQ}jG&<4s#U8x zIy%zQ(tt`_TwLzny{n|8w0rk%*1p!wKq1DGAirP+hi5lH@;06>jv*W~lM@^mwy|h5 zw>K&>t3?#@dK4HgV0xy_%cHZ$q3r-0Tim0 V+U**QJAno3s_q_hHjLR|m<{|{uod-v|{-MeSb zoY}p5_o`K^X3m^hR#w*0(c$duY-D7lsHi9)AfUIByB4UFu_VYZn8D%MjWi&~)6>N< zgkxrMf`a&laDxhll>z!~d+|NogYXO@?jhlYl} zd-u-R*!awuGlGJGt5&V*=;%mGO9Lu&adEkO_pXwX((c{6ef%(D=}S zfti{6f(aiR+qV20SKqcpck`ame;~pT^rwbtyR5^X?>ue^g$I}EDs(MwP;Xq|z2O!o bi!=k1y_jR{v$iQf3mH6J{an^LB{Ts5kk(LK diff --git a/docs/html/img22.png b/docs/html/img22.png index 6a7336dd74bd2b9988e0067617cb07afa1f14f3b..a12cbab4b176e9ca8d96f9deae41584f13853494 100644 GIT binary patch delta 170 zcmX@fxRY^$cs(BrGXn#|+cbkmKuRmXC&cyt|NlVdyLa#I-o1O~%$eQ0cduHtYUa$D zWo2a@9UUPdAzopr0H&)vvH$=8 delta 186 zcmdnVc#?5~cs(x*GXn#o%-5n@3=9lf0X`wF|NsA=Idf)tdHK6{@6Mb#BPb}iYSpTa zj*hgnG@ud}7ni$t?8W4$S;_|;n@w4ysxK=V+hC0}(nZ2@iZ5jLu3qXst6yU@%Q)W7BK9$-^^;$5>cG;>Npq$3mFc&v;8{-Dvo7 mj+@7vwPDLjMrT!KW`?(RTzNY$N=E=qX7F_Nb6Mw<&;$UKr$T-J diff --git a/docs/html/img23.png b/docs/html/img23.png index 8820cddeaedb8247cf2defa7392439ca2c3372c6..8faf23ee2acccf00e2abe1e83a511f8e55e594d0 100644 GIT binary patch literal 201 zcmeAS@N?(olHy`uVBq!ia0vp@KrF|?3?y0GJF9?{dVo)e>;M1%-@SWx_wL;@XU^>2 zy?fQFRWoPKEGsMP=;%mIO$`YNadviAR8&lj3`_xPVJr#q3ubV5b|VeQ3Gj4r4B?oW zoN$1-M`6m$Y{rhHoP--3i!50r_!=_V%r@-s{N=S_6B}C|E63S;3=1tCO*S(#^Lxxu xZd@q4X6;p3owEly!p>eclR1XfD}iP+c)I$ztaD0e0s#9IM$`ZR literal 225 zcmeAS@N?(olHy`uVBq!ia0vp^d_XM6!py+HICDGGdmu+Ez$e7@|NsBx<>jHFq3_x+&MmUI+Gd8o_P~|zprBJ2M+^pYmEiFNdA+jdX_{hSPn~V$% XzTC=BpB>TxTFBt(>gTe~DWM4f!B9%f diff --git a/docs/html/img24.png b/docs/html/img24.png index 87dfb3617e0beb11fe0895d44d446b3ed411cad2..45001db343b579a3b2683e1e6cdf51eb48856457 100644 GIT binary patch delta 399 zcmV;A0dW4+1EB+u9De{QECdh$001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCeNy-H87wLbGF~?UIjjXxQKsozav;uSuVC|>xcaeoZ_CUFd`pLh~L7Wlwj&VGOy!eDs-w8n=aj@^%er+`tR0NM4~Tn*4D zWIX`1hAXW$jbmyX15cy^NNfRA)$H`8lc2smT9?4U;KX3SpaSGUd<2UuW(5`)i$!07 tfgmt+=pd|!LBq0v2vtl$L?{9S0F5I(MJyHMjQ{`u00>D%PDHLkV1o80pRfP` delta 451 zcmV;!0X+Vp1JwhN9De~`D>Q}x001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCxwWI52E5*uba2zCfqUc#{n?oz5&BB1|9{@1w0EFesh4tI3i$* z*cfD>teXZL0Svz#*suL&V0gs(Apt1liLmWG1H@6>7d-eH7#Qb&{?Dc_$-vbCc9H>9 t4Ns%wHwcSSVks`qApvFHBSfeI0RYqZMGy#000{V0{{R3#_n$}0000mP)t-s|Ns90 z008dp?%mzp%*@QYySu8Ys+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001 zbW%=J06^y0W&i*IGD$>1R5*=eU>F6&1D5WFsO3bc>tNt6AVS$O27Ut~l!=Ab!P(3k zap_>a8oCO>^8=H7n94XB7`7vLv%q95rZS!chR+BdL`Mgh+<>Htxv{}R0><$u`^;cb zS&;F%3FI1>|Cy$5$$>h#yn&^Gf#nk01C~n+R~UpqLfSCRoD3)U93cJ(IRJDcUjgR= zo&tswtQUYn?9W0$AOIKv3{PR+ z46L7c5Kpv)LhAaJGCrg2PdW8jHY z0EsPt%FRw+Itj|u34aD8ofr%lRDd+ZU$A&%R$zfyZ{YNafiPee0sD>+U}~O0genFG eRRyAyfdBx_e?XMSHaQvq0000m_n1t z@z($Vmg!$^ohL$_5(Cc%7@I#1r)m5D&q44GLUn?G1F|wE1qKV44#l4V440Y&gf=Mv zd29+WB@+5g4G`9S1BPV`dJN1BJPHi^IS&9uI3i%G*ccYUm^TeL0vL8M{Ner0z;uB1 zLjq996K)~z23U&azQEVOkn}@n3ZsTD16Lzh%m6Ca^U>l9l*uTu6qg^7fimwAVw8aZ Y0I_XGENs)f8~^|S07*qoM6N<$f&@pt?*IS* diff --git a/docs/html/img26.png b/docs/html/img26.png index 7bb6f1e1499f9158c58e068883f892658149b069..99fa30f2811f2fe139353592eef6409a827db495 100644 GIT binary patch literal 258 zcmeAS@N?(olHy`uVBq!ia0vp^Qb5el!VDxi>JME7QU(D&A+G=b{|7SPy?b}}?%gwI z&g|a3d)2B{GiS~$D=X{h=txaX4G9Txc6K&0GE!7j6c7+dda1q(sDZI0$S;_|;n|He zAg968#W93qW^#f8t3ker!?RzFo^~4fVl#SLKW%G1$!G8~@Y~FTi#91dE)|||xTy0j z<7w44Z62qDv#fKtE4U>5HpDS}lo8#*Eh8$iuh68SqLAm0S|QJx`4vJk4L0&^7G?Hq z^O)RPnH2i9*P8VvXGt^rFJbanDcsE1%r${ci-lpGp_Bl(3v(3EEexKnelF{r5}E*A CBUo+# literal 267 zcmeAS@N?(olHy`uVBq!ia0vp^l0eMI!py+H7%x2QDUf3j;1lBd|NsA)GiR2UmxqRi zzI*r1*x2~YnKOcdf~!`o>gec5OG^VPba8RHd-txAlG5(oyX9pSrvil-OM?7@862M7 z0LgcHx;Tb#%uG&5NO+LVAjIQuZeS3@U>G50u%O{LUyp~)f+bAM%B0$u%ymtde( diff --git a/docs/html/img27.png b/docs/html/img27.png index e3b06a48c325a65e036275e6611472e0b371f081..1e72eec97a7f6e1ed7f2cbb596991df084dd455b 100644 GIT binary patch literal 2500 zcmV;#2|M002n@0{{R3Iorvm0000mP)t-s|Ns90 z008dp?%mzp%*@QYySu8Ys+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001 zbW%=J06^y0W&i*QLPdFGkW=-1-mk%@}8dE(YjT1F*vuVRzP(Hv7jxeDfWu8rF>`&L{S{uO~7w zrfFW=lDV!=9}vy%^VEBPi>%yaIDkc}^df!eBPX$pHoq3zXjA&j>aTriIJt8mnaMyy z2ji8Js~03pqN;I-Xu3n;?cJlm-P}Lz z4%y_Kdg)nkesUbm$G#lE`r*A${4;ifdvW3aDEMI*mHs3R7L{&&V^Cr(nG_JQpcmC5EUwdtjk7n`YcE{$qbIsk=B5Q2Ms zGg#N*EPNY2gB?R%dP#L0CCP*iR=kkAxtHNMTe^dd0IRD@0+@gmfpr-^p;G9_|Ev6w z*sSwlQR!WQ)x(~pAt!(fa6_zPx0pKv#u@axeac+|D_wOi@y=Bhds1ccDqNRwqhzUK zHdBLg<{FjI<*GfzyGoNV3WMVoW@<`z%`q|>0B1ROL!Uc2#YMp)fbXDJVHviIb?6?F z(rMYFQX%LMDgLs5!FbS;G1Iu{lR{{Q_GIkoY{+Oj{qF*>#KTX!H=#mDjg0( zy!2=3`e#Z%M6t*d9{HeeIytAe#Y-PhrAuI?Q-wP3#0ckACL8vrmd<8sP|jRqRQjDC z0X^#gHFyR)nbP%w|JiG(KqX@@=Wgh;f@i&S?3*;}==Tn$P{PTnVK3~x9c|XrVZ8Je z>*A$w%QgC9u+o-4)*XJiuF$iS;j-kSkx5ES)B7rurynu2BgW z{E|OP>3AO8hBxxw)|WZhMti86J4wq8wYWn0R;`-#CY|g5gim4$Zorp0@T`mR6}0%A zE}bs~RX*3Pnit@`=Bj$uxgT!n)BR(mOJHSxK^>RX75lPe;x2=K2eDbFZs;Xus*iH! z8f9#}%t7HKz}6|8zk7zqVDw?Sr{l444^QDC?n*w1ZX18D!rj~xn_hrLJ z4_1yJe+i_&`^ymj9XShIFhLHi;v6kc(M}w8yDynouWo*3j7&=2J3wA+#`-`?qZ$E@ zP={aR|BCLt2HSU0<9ph&GEq4UI2GMZu1dJBtrzh&Lq}%YT z`s``hzIH_274>h>8e_*(vR4*A56hX@{`CIRL7OFKJqB3y)b8f_HswKfAYs9kvpap% zuwfH(JytYZMQEp5b32}h#U}3`GgXrZ*^)A+yuP@Ca*6rB7bK1()!^Cn(XkVUn=Ni$wXG)TqDhK(R9?&|A*e) zfU18aJ3!Sx61Tde(Gkfbpz?zIYFPm)iDk6kxe;yT5KyhG(34;`fJ$O%S?AF~A$|s<5 zzTX#S1*jyJ0aP3M`XSGN>Qm)%Ju5&Zu{5Bv|55$`bO2QcP^GH_sM72mKs6V2098jF z!Mhz$eg0e70V;|W$=wkplutmlDnmfEssT`0Z$%q91XSH;y6Ra0Dv4$EH;8?EEQf%q z;CG$O3Q$Qbqle&k(MApd6~M-7X5XOVSS0xdmGhFMvv7X+Y&%VM>x;K;=C;=w}6}B$oLG)xouRQso&?t))em5uoB&22k1j zuH6AtEz|*2Y4#4Fnu|Jss-uo(tOql3qLXf}By6rCx-*^dq;n_{VXVT?EC(Sc^BX?~ zS9GauNy6qs1CVmtPURyk%6W-q9p)z7=6+31`Zs<8uJ{JqiiFLFW?A~a_(rH3Uh6T~ zN&Nyuz!j6CRwQgbG|SQ_Q+p+!_L5GjbOo;HHzBP^*v%7jAwzd`<_w~U8)*(j?ZNtz z9vFOO`@YA2qc9dxUJCHFYau*2vG}J7O|gnE2LmCqFTz7 zSn2k1;zpW7srCg^I)BefW}W`J0JooJKl8?A-#VseUHp}kE?t4E1zYgUg(A9RN+%FS z+(>gMX!}U!Pn$RTVTP6bZfv!oCcH5-0wR-w_SL zm=vXuu=x-%n}7_&rTx@2jaVNj71iNO_`@#5 O00003=8lI&^U&DQ``a=;0ry_bgszV!tx!`@nCAK4PNj zj7|f7!#xg-TQoBFk?Lsq(A*{jo+msb7;VBr;E_z>O<8rWgfypsq|Z>ufhMntJA~+# zGM7^Qdn3Ecu7;JtVdmmmsR6I0v_GEVAbNumm{VT;FA$|(I}IY0?Fx0apQ1}mEjwK zFsV7%UkI%+=Zyfn(@8Oxz=hn2{$;w9$TE^~Xo|NV*5a4mzRm)@#RH91CwkIG(;9|u znsAAMSF5Q&@MW6nxo{i4*>1F>0Mt1cZ-UU8lhkjPL;hlmGLWN1!R$$Lbu`>vkg{L= zVp2QH>c+}V??CJ{r4_|<~>MjmWn%otuN#H9fN-lgM)c+lj_n#eI z#Mfx+t*Si;<5W%(7nbm9BjV5T)|H*M+&)MsD}Esb8|ct|dhHN1D;*!VuZU}{qd}Jx z!?-L0M&KB~9cwRoqqQ5|+_m>C-Fr^3jL}r7^g0;r`IdW`!pBP@5*Q3te3)kxz;u4y zC)^!*3&bn|{}I=`j)YNd4IzRnnubzN!!&pVc%#vgF>99g2HYILWF-bZ?hmSi0l48X z^3X{z4@-s(87EwWa5?Xxi~5m(*ymEKhrKRtc8y6~(NIVC#-X+kUa5juQuH>m?ecB| zUn;orXgf=MOZ=ZPRB6hfPzCf z&8wCW3!l=Bw7~i6}nsQnMWk`F$}DqsC7j1QZLh((~LD;gno@ zO;ZdOt*l(Gm?k3jzu4<6bR>KVych6wBs;C3TlrR)WY_3!KvVGgu#AASz8LEn0@rJY zdy>QiPl)NE3pa83y1J1JwXnZ-E@Da11M?uvwRQz4f3fi?y3~A=zj?QL zV4{y4@hP1QQLHG#>fnqRKR$3z8SWe~H|3dO@f62DTP7N9xrf^#Q(e{T%!Eh?S+8R> z)q{oLGd6X4X|Gd%Eh4MVjlKwA;z&qmB~Oy<5+Ot2QV)xdzc^KFQkcQg1PIhk$q-KS z$}b>RPW0jc0$fkpqtZV&)3)6q(;^u4o=*ytl6Q4ax?iEQRWaD&ygJuX$E!FD0c{)H z7n%E^j^b7@tZTuFVI4X|>H7-I1z+V`CuH28=<{#SvRjoo=`MHxbdYyz4cyUv4uoy5 zhO}tml??P8;e`e&X+XIdy6%nm_cYlmJV0~`4hSa-BS;n1fk>+SA@PKO9Qvg0iJ2AD zHF;`(CrGVFxyD7X;Ic<1SWb?jo#`}UB9U1$^V3FiAz#oi5)nl;2=sx$Rly(Ro&lG# z&gJaMd0FIj9#;|3rRXdo zTs=s1--xY>hgbqgR4GUc(uWAty&`nyP{q90)2pzT$|Ap$ChHJ)j@hQb^Ig&xfU49 z*xGZJek*M8^nYoK=vKJbS}5{lzaug$bgX+|8S0K`qOW<+9>dLeyP$DT%YbBX!sf@??IEtArd*#il8 zM=*PZLbV%mk0Px|CW44Nqgv2@I0Gq7EcwYU^C;I}sUE}Q&GcSv3(Oy2+t6A%y!9ws z^3el)SZd(W19SyRJf7ig)CQU8gsJ7FudyX5=CftuDQ;iI#u&Rg7bF-%n3& z%GTYC?PF6psrL~beFA-qSXW7k0Yf0YU|!qo;IJ2@U<78Hr>53jl>|jog;)!Qg zW@((v$}G$Dzr_pG$-?nvR}l)wz&+^VyW1n~c00u#|0o#| z52i1e+0j;414?k#z`eqifAS-~@VeWBUBMySSi0C&&SCW_52H#QE`W+N`v*!wOXLU- zVJ3F5jlqg-ho(A1n=U_b?yEvK^OO!I)uPUIhE;N(sLH0U)29sy(65pz1?lgsGU)+c zfcVbzlNzIEm+O0z=08UG%m<^!?nj3+OC-ti2e>}OdTNl(LNP-+KM6-J4c3ffFnCdC zco$pcvvIdqIB9TXICNKGmXah_$%+RC*{}e%UdnESryhL^CL(hV-10Aa*}sZrTLT=e zU*3;d*Y*7-7(ZSX2_%#krmh2h<9TSZe|`#6rvB}qO;c)i2pN3D|C60?-nz?rJSCsC z{S%(#yLlNC*807&w;z2K1j>_OzH9z&q`YVY>nAGSu)MEHbhOQQ_?42}vfRq6zF{$d zowvVDDkD_88+l16cfp)haV@fFCUQ#O1EA2UD}ZBcq>+fP`4iYDdi7T3y8#)5Jup2mVkh+I*JAA76*5Cf_JzNk zqyc+w2+@UVwN!SAjdSh{Rd@03TD^?cvNnO4aJ^nnscys96V>&;BeamJqXt@!(rAfX zKFdy9@bc$jK=qKX8P({&>lkr_ORN49xH49K{uMd+qGU#r{EB{DHnPGZ-yZ-`^Q3Bm zSE4%ojC2@11MaA|-~-1fOW20twZ4eLD}zTiV!I%hPxcfUWqa%^!Q*kNL6-wh%oyYyLX& zc!ri!rfqZjZJVah;RD!FKaT{MpqM$mbQM_B9NB&kq$IF$dAUtpAxv;`cpu)-M{0+$ zAygw?a!lh;1o77O`@ylnk~qfkD+cF5`nNd&?+3U!*$YSSith0Kij)6|`?#Srr2kHN z(_3pJzjJNquO@`&|I?6y*Y8`$b;NvqZ{b>xp)jSnGQ5l9RkYT%fM~_ws(*;v>WGwP zDr$7EEs$VPl6*=NVGXhwvevhWAc)5`g%?lAF@)#xti_4s{_ue{VKIgH!RX_#VwsAe zo9{6FwPkY{;TflQe{eVGTx(#m-H9evsa3GA`;5ayNEGvni$zb(c^`c!@FhU}E6Hxm zl_C)GQJ>hCIucoFP=(XHDP;d8dh3#}id!JakL)MyqiI!Y!K4&vJIuxXf26M_ad1vB z6O!C)%C6kL{tY-P8>E`xm006vVK!$h^aJ?h%TWfRb&9Qp#1F!bCvT$0is)f&bj!#3 zeK6=_6w9N3aW)4R;$Jzoew~=bdFny&NkParE=?&@D`{>~N<&oR-ST|h4n>j75M$@& z!fa02wjvv(n&6d;O}6D->xwU<$tsw`n}_-fML9ee4!-qY;4$BD;CoVa2QOd4<&D-l zf>J@%g~`j>B8P_^=AS_ow8ZQRlHc8@;}LyNatCFnG2ePvm3{(_P^i#(R&}@pQ%EA= zLRfw_$Ztw+D2Zo!Jf%7d-{GR5=7C@#c*(KyplSrmQKR7GHki_!59&7y$vm5Vq@(pZ zr8Fq}Z6onl2k}AaAjDr051!XksbU20>G#hpB%@~0(GRAQD(my3WV41Gm}$wV3;lhg z@JGOq^ZIFcJpwuW+)QiT3RGv$q)&iXy!Fz!eJU2H*evtbt3ZXv&vZ)j*t(=NFjh7< zoXu(ls{cCcSD<<-+)ZVHNSVje^Yi7_arwdf8fjhkabb)FOaJoQs zqHyQBAkhMTX3es!5t5I8(w%(RbXsjnG#bwu@&BC(X+yZdSOLaY>Vm*)v@M=BD{*Ab@f@$XT$1FqWU8+;g+Z(5!RtfjyUmql)XFz zVay#XmCrBW^S+(wPL4Hg%#<%|K53=a9VcyHB zP8Ff@j~XwXeQ&p1%B%H zYkcd~Ksku5|Ki`LPnNpl!002@@@j*_KJ+L+x*AfI%2NQ?VlZk->OaE|!e9nG42d#9 eeI&D20saRQCGB|v?dPxn0000$(H0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*J8A(Jz zR7i>KRL^S@K@|Sj?2lQKM(AI#1rbHTSP=9!y+{r{Y{k&@wtuvWUW8C6RU>6en-D=T zhgRF02L+G8gSiHap3@#Y7u36;e}MBQGf8H%#Y+!8^c^N|zwf15$_&P;_Xz%8t@<|GNgjo?8b=?-%aAT?Fi#*;7zQ&3VZGmL_Vsc3h#ao zp|DQeE{LC=&{`F_o#K_-lK4Q2@IAy`pja!Hij7&c;D0dzO2o#)3YqkHF$NP_IBsFU zEBBj)S0Tp^bCnqW;gQs$uBNmwgOL_RYc2f1w1rpI*e%G9Rp%ET15eyR4b&lRFHrJL zj^F2|M)%n3Tlk(DyBRn;fANWW-@Tmbz2Er=LCRGsBEOoL-g`YpxICrCn`-QW-A8CF zB{UN++kYsi;klr-!q3l_BKq%NW0QmJL-TOHZX^}JaX=hXdHJ&T~V|u|HM0_Z@uPk@|K0C?htl|f+-6r@YdLd@)5fuEIf6$ q!A^X0wnno0*STlo={M)>*grsyfTConvJ3zK00{s|MNUMnLSTYNnLSPb delta 781 zcmV+o1M>Wv1(ybp7k?ZC0{{R41_NvP0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*Jl}SWF zR7i>KRlSSUP!Rtm8N*1#qB;aDB%7RZ%DiG`#aznlEILzNr_@^X=fc6MD0Ne*YOh`JBgyeF4 z7%+kLGl9!nJ%0k9Bv10zWmt96MVK|&tzk<4SaO?#uh!hZ-N_DQ0AV4>yl$3RV_eHE zGzh(L^CkDri4voZxv<{rIq4L%e!tJl^vEzJ%}J}oOsPth3nEKdRa9*hh7WBLV@J(7@#WcQ^20000< LMFvhpu0mjfGrMt5 diff --git a/docs/html/img29.png b/docs/html/img29.png index a39cee90cac107b421587a79c88a0aeedfda1d1f..77e1e3d3db84dc5aa67e2a46d09f7ed568428871 100644 GIT binary patch literal 238 zcmeAS@N?(olHy`uVBq!ia0vp^Qb5ed!VDx2D+?9?DT4r?5ZC|z{{xxt-o3kf_wJc9 zXLj%2y=v8}nKNgWm6dgLbfl)HhJ=JTJ3AX087V3%3J3@!y;R=?)WBF0w_4pT4wLxB5cdHWje$a@jqvbXXRtdYt2&7Pq1b_Ts$p}ZC{x3 zgiGgnbQUe-;mHx#XSCGemxy3(C=t9IJVBFNVg`$ZN#s6*9Hvh@xFsaC4s%IFDGN8) hq$#8oF*&MYr4fA{X4 zv9a-)GiL+^1y`+F)zQ(BmX-!o<>KOU_wHRKC8gcFcXLY45CjS_mIV0)GdMiE0g^BC zba4#fn3wX=Ms0(;HP(mM16*ls7awHa=uD)@JrQV7xIw zu33qh`8AWDTbrc=BdZ=8pPoYQfzN&GCAQnWX=sjCoO_cwW4W>Ljh+4y5;wlc85?x0 pVe`&UPk5l0utG4=;^YAa2FY?k1+H@OI-m;}JYD@<);T3K0RZ2qQGoye diff --git a/docs/html/img3.png b/docs/html/img3.png index 869e09eb2d53a8c79295a6821ce0df639fcc5bfa..0437386d27ae643790526ce87bec42fc4b776e5d 100644 GIT binary patch delta 2443 zcmY*bYdjNd8%NA(&yo%EVBw*RoTlXT(BphcSZykVq-HEEk;WV+r519?Aqn#&mN$py zP_(^`LP(CoHp()mIfN+Q^*&$T_x^JI?*Hj`{jTf&aQ8xQgYPR7MT7?@VwNW?V%NMq zkRp5Mvosq;M5OIp?Eg9)TfA7(+gPKcM3OG^HcB;>Kt}XS-xn(fb(|%~aXuFjOaRA4 zhg%NZPgWCy_lKEoAyK)1t32OS-LSY*ozl^byrQsLe`$ke>}rW5gT)UAyWFuX%qifU z&O-CLy=LDKh~{zzRCib^7K?=b-K`J&go0ALa-U7mPlTs&Z~HdC*9YR~hrMoNS^P8W zcXU?ARo`ENg{qC|upVCe6oB?p4#giqkC@JPg}lAQcN1Rnp#?j)!qJ;2D~-hgLl(d> zX|A`kL2WQ!(*9cs$8jhdJ&SKvLO5g2FYU+ZRTJfGEonB|HBU2fHK7F5txz@O#fJ@T zJ3dRfz*_I=KtX?pEfi{RR^9+re(cxaMq2K|;&n#UA9&|VrTa+jvzxaG9RwjQZz<+X zW+d5xJI3~qgPDk!Ii@Fi`m%N=1{S_dokdv@ zD{8lF4BpF7Q@v_b_`_|6o35mxGIl`fG}ffcu@JhuJ>JiIe+C!$xQQO&K=u8i2nf{! zqCfuwxnb8NW@lcD+bQ1ap0@=>5{7qU&p4y8#pmj>=2d20yZbyLxUvWw#=Fq|dJ_G< zR+b+})(DdJBqA$WaZ3LEKsZrPzvtRIf@DC=YJc>`)N@aQAwW#3KS)$g4z2Sg^{=Ch z@nF(-k+q_SgRsGkyN%V%{>!bhDJZj3{LoPw3(D?w!{2#cO313E;N(GE0Mz!u!g7Sc zG27F+Jvrwnk_>_NhjI^O6-Bz2xhv3cKVZXWHP{s#zKhQ)kmPw)5#g3xDr5<}SGAu@ zH*Ta!rrcetz?00#76@mb*@5O%eo`5E@hU@Z)`bU*gdIbOB)>>;8^r_T6Uq|IQ>eP_ zx0!u8=ibF#)Z0~R<5=;{qIJ0mxeOk4qFtjV?nXL0eKKSn5?W#x81BGr)#Kbc6-6^? zR%7#VWTrL1g2?ieLvCIf7{jx73{g@rFZDWoQl#|ci~14DdS?zqDy&FjeO?PmS!PXb z{@A^MSIF=Co_lS#OG84;?Miz8^NXl&)RAC9e&1#}r|Ng~$Fx73AW}!tM0dbFQABHo2SB@dJa0jUsvQGDO ziy=3u4UrbdjwT#mF1HYfevLl!UcLlZrgh4$aL1{j2i|xBPYuu zL zG!0@*lU16KLqS0yYqH}ThJ}WXY`ii8PO3Aj(MKEQ%dYeA6NGG^CgXgxTAQO|I+$}!uJu9lB<+yl!Ka7KZSD1tO8*hN89()9-ka336*e<>1=7UWDiPujUG)jWWG6M`bqm*agg;bJ>}ICs%PO56wOYwPrqX93&r-Ig*i_ID)7%S84(h82^kAw zX&Nq?FHZhF6(D#guMhB&fM$noy)Tq z62qX#R_(T)>qK99cyXgWsjhdwe~6_)2IRwd0%`1?n`T;lQ)yt+Otv$(CVbD@ou$9> zg&o`j=3;_Pmi=w5AEpFd4a_m4n`1vU5 z2Y4+gjNs%eSZ8;?ycV?Obm8dDvny6SeOaiojDLIYwK?O8F7H*oAN4tTNWmGsx^w)K zD;goCy5g<564(}LDX4GkrnxCc?4#7Ozi0cM9R>Xen?&q2F7_v0PJm}?Gp-Xk`jy&@ zQ1ZrT*zNfd_*7n7!XJ>ZsV_1?KMG0?yy{Q~^4>Hog;^PfNp5sf8miCC(A0xtgM1bT z9u?MlJx4AC)+xMfkp!sLBk8X5`v?JV8RO|qgRwB2B=aKj+yw;Q0s*O5D?Q! zV;iscbRb7(3MK^{=C;T|A0jt&>g!mn{{#rw8G`vUvs?h<@5=UxZb<$?huqmbiAm+?92@_A7xmGF{Q+K3wR1hbGm6A z_RQAAiBxw-E7qK{lU&BnjAZ8(H=}Jrs%X=LyLSMVrmQMM*1fs2&ri|@piGbP1pgq!sp%`Y^wwoR}NvjHoh19JMm@%k;iD# zwa(WvO7)xQ2ZR%XGTxH>g|Yy_sh=*}be~`!MC!?j5YsR{ps99Skv9#0el)j zp5+z#;(5M2Ukf1kuk?!>#*nc9Gn{&zWh{QdRZkfD`oRXmeKU5T2#m2zG^|vjKCs^L z9`7}pnt97Q?k)7KFSud`^FQK9D=@z+Hnw+7<0AjBe&@Zgb{KH}m(`_qT@&!W)&N`# zHIFeWfnSg{k1O)1$i%9>uyx0(QB6Mf=_dH@iLOVTL$;Iq-G6<%TpT>?#i_Od$^QXX C%dB1i literal 3149 zcmV-T46^fyP)0flC>#}qlBS!?b3Kg+=6WZ-!MV>`^To9wnstoUq5Ei;KoCe#`kF-&5JLqv zB^2kAJm;v=UNKc&V#PI3booiR1%p@8A}S%x3nP6C*oal`b0K!8Lp)Y)l zP2WCF(3W@^)D76&obX!I$d|^y_b0cfWf)XxT6EA2U=^Oa5}$dXfRVt;>c=iLCHnTo z!Hw8Y)c)t{F;#DhG2Ep>?nV4?`ts}cDqWAM`;+wcu}?p>#8*S_3rJ`(EHxOso0n7~q9^TigF3Dk*d>x^Dv9oDAJtI2Y9d*vAWaS*a#BuhE+ z&p=rUAde~e8b;sIWcDF4foh17wWnA8$Rh3Plcxy#>SW&}6gQ&#n|(a};GRev^8YQ886g9V+*~kDLe~+PF|F&P#D2mJG<`C2wLFKv^D>P0g1_}X z+~s(1agO&I@iNDXr}{L<8Y<@ZSNf-4pzV!r1%7aJ3>S22!T4CwKO{Ws%}JZkajmaU zh?FM{KJ*>_yYIkjNIe0!$(Ea{uHc2mJo;h!149R3g#qCld!c?~#wtDaj5GdY2+V~w znkqQXZJkt=4%U))ocKE^MD&d|5H*4lm>L=NKz?rSYY~Kq){54M1d%ZZE20_%b40LN z3h=~Sqi&&!g7Y_C_tEILME;u^2(_EwdsaMLr~8dOsmWwclZ)|p3(?*x19lseEefOA zKibm&C=7}SVNvkYELm@)GmU6L%7CKpbq^c>^9N~a3a6I4eswiolJV6H>v}P3`1$LFoxbuOQyg6NL4O+9+!m{8-*Rq@IMJ zk`dBNQn&oXOx?2-eu$|HT%gdEKv1!2Dr!=VY#d>0FnEAy%PV`IS)gtD%y!~BD~GzZ>|l!dboEzeTrZ@0k*fK zL!u_t8we8V2wp3I8VE7@5p@p4K^}?YaPu+)@F4=EzcDjL6=WXL=^|7@sGRmiE@?%4 z6EyP^GMorMfv}R+XgW(FYUwP?P^)q~5q<|DisvpDbniHljKf4~An<7FfdA0w>T*5IQ~urKaZlpz&# zJAJPff+6i`^!h0zmE=RO-*jyq7QhJ4%X>ZybbIoKuv@VUgIlp}Oy@szD;~VIo(QWM z?yqdTV0I|=?bA#f(hpX$6X78%c%Bq+UYVFY9CR@76kqfS0x2dj{lPrm_(^sjA@m%8 zEPSsMf@Fw(Vou`&1R5FjRR$@VDQ)!=1k!FhC7kL^RM194iYmXGdI+Ttaw7aJ!m>Qu zBdntBy))$@8%G;(-_tQG<%zI?s{DLG0kAv6Nx5JXkwpl}ent%@3}H}aW%}asM2>J)8*dGA(hAESzb@rHO~*0znq_QA?Sxq=eA%ijIj+j)ULF->Vy4 zLI6wwUK0>6W$eeLe`8myU(HQqgf4+N5n?CUQ4D09a>Qt~mh9qS^Mt>?5tK)92iE?t z7kNOZTVVObS|h<+$C><1GWe+vG7TG;|LH}REoL%A$U_FASOqW$eT>y#C+id z<@SeVn@f-k&9LDcGsmK3BDwvs8>&o(v?UyK?nL2x&F!zWpJo|IPj7e~erTa+;xxBE z>II74!%1JE1q1coZ*h-Uk=l_a``7d>5cid0E3`eOIAz$M@19tv49CFwwhZRkXmW}! zKihNdOC9OUGHBmEE4k0<-g})~k8YKc*I*hc}aYdWJE z2o8<*?CLit`Q#WfJl$G5|F}OwX-)=u5AA51l6@DlaTf;Lm8{yUwF=`5`GRMZ|4-Mjx9-goFAG%rI?`~@%V5QKG#4voeC079Uy%JUXX zKs{=@^DQcP510N&b~NB!I#B)u5e_}iaOX?3LBu7(Q9gr@TwjRR$l@Z@{Uq;m$DMiXLSEaOvR! zhd}eQ>%O~@K>_$-DTJHfjOKgqfdo+O64m)sjWTEuKJ75vYSHqdj9CZq*`|*HbINcG zm{W#h!0cr}`~@3mJEY%_JNbqeq;$p0=F4I>rQ<$XF&(*hOX)Aj@E7XRybKoowjU(? zoaWyHer=wul*(inRuQD=3@e36Yv2#_dJ1I_V`v5nB?~j|Mn&x*uOb+uGd%WEORTa_ zQ58B+ajvFQhGWo@zV*R@c9^h}A{mCT6aGTUeb|Wv4mHuhAy?lEJ6Y1VqIe2B2}cM! zStNsg3_HP?!cM$4_KRUB|BN<$d^%+~2K_l1s=7h$Tp^oo_koi?>w#^|`TpltK`Pr- z*XKvy4rxaj08^m9Dz=}8DdR_aFi{_5Fy6&GfXj{sP7Mh_mYKOzGDM#HP1C&EL1V~p zc90J_qF4ZQq!Bqc?8G)q87IBZO8y?Qvx@XV&hB|1c2J~4J;=bBUPR*$ZHMm`=`2$+ zh=@`KM(Ig?10h>tl@2+g*zvY zB<;)eBF2Zhq)|a8L-XEK+>KEy6;>IoK7g|q=-GL``r!~ z$`Dnz$Uw;H*Y-;VM#1YJm1)Dib+;*!9ma<@S85^6a2`XE;x%2Ln|!Z%vE3Wa^H*-@ zcKjQLwpb{1kqjJ)bY!zhu npZPS$jZ14AU&HoNB(VPjnnXP)KlD$jAKpci&YLX^t+Jb*UItYpugY*xGBBEF{3PnUL zMWG5JWRMQ^gMfk^6uJ~Tc2PTa@?#UUj#3nyI|OleDY$rdO)D*kEm?~6ogTRNx!m0^ zKtKKTR-`6nyO+f#Sv@G1I+ABo1?eJnI=90RBl|NCWPvxGM*L~}B=rbBcZGCWzNNBL zAu{(OR5#DnctSBKBCA+7Sr~0>&)fJw21+)ld2CUmGOG+xIbcc!;|9A3=oFy`45E17 zV>AT$D#|#6p!*Fh?y+ODN{q^rs?WqH*?Xam2%%NJXEIk@Hy~E(cMdh~97iz1Rq=)l zM-eyxIUAzQW7p+zU0KF(u`ZK}bWG(a;$ErX8H7DeQ79GJ2$~P($V&*uV1*MzW|fUs zD$B{kq|f9lC}$~3*XdQ2N(Dz=tBGGL&(>Hje|J>z*EEQ%!j;&lrl1V~DmaFifX*bX zZM>16In#=~<>C*MlU>LjqgAHqSmxcxu99zmz%C+$UC5Ys;o{Q#yYsu8aP#SZlyAiM VZT}J@`{V!s002ovPDHLkV1hy}=12el literal 591 zcmV-V0Klrc-gP!PxeNn_gNwTVz2v{fQ#6-4VNkT*E!rki6e z_zlEC5YmDmF0G; zjUBU3 zmYC*Qz#0EL@;glvPIp1@2((YvWI! zl_MjYP|FbvttxXC%Oy)AHaiZFej7xG&dvHWVnIaMB7F0ob+T-B5lAsM!PdI$x-pq0 zzGQ3;Pa>Atzqq5mQBNPmqdm-K>ezis0$7-Z6uhk+Alx%~I d7TbWoS?~8oY2?XkDLViF002ovPDHLkV1lc`4J7~o diff --git a/docs/html/img31.png b/docs/html/img31.png index b0759f28c537a74501498c37eea35679c0b9351c..04db189a824c12f29abeddc0573befd473176678 100644 GIT binary patch literal 894 zcmV-^1A+XBP)y^~)Yz)?cF2_}lLj`S+V55EcPt@q9iO&U-G&T5Y0uil^J@i)-jYT4 z{PmiubrqzL1|03pspGwa$GW*GjJ&+aetRix@se-5`g`9XaV8yj5qoYzEU=Pei9U#f z56H0-aH~S~iixqdu1k;dhyqQ0N2VN-l7cuZFSHM9$y6xDOcn3K>_VJdkV^QBA{BJ;MkS zBW{tX*FzdrSf)s8*%TToR0~}7_`n=63`-UDI>eoE?vxW&s4_~uu9)HiQ$?ePM5;;D zAEd}UhD2r}P~f89kt zo^xG)M>!>Qam$a#Wx~;^h{(H_}2Y-=UkCyEaWiN6&R8!lbTE)MGUvP!V U{~AoNGynhq07*qoM6N<$f{JseA^-pY literal 1090 zcmV-I1ikx-P)#~Z5 zt`>y42XZzM5yTIjJWFRTN>|9( zKJ!37QG4h!QfMrhG@~0=BCIJBskoKhJqB^8f2FFuRQS}h_=?|y?}T6bXdMREuG_eA z-T)dEZ`{{i4ZxZstozryrfex1Y}IcRJu**<94e)A)X}jhjErTaq)Cyi9QlpNqz@B; z^5AJO0-#Jm6vL2-vN;L8r?^}MT$?d%|3u5GA1!UH+@$u(@*jx)a9%!m@ZfET>j&I@ z-&1&r8XtN2HmTzhc#g4pX1-A1{y={#Hc>R3wC*VMQ~=IfdV?KD?QFaYlAUO_xhUj~ zBt8Sr7#9gb*J%)K1bdJ-F&n5kv@=6p;z1Z^6|0KMX&`H)G2G6Fj3OHw@_GsR!Q1JW zT<1Ipf;J_wkjbB=(Wy{!!Gm}heKvy~Y@N2voCj2*h9Viw7Jf3~_{ zWaMAF62CFcW{Ek(Y#9J)#)%-z9Jl1&1PRy6-LOb98+)1vwHZ;{L7aL;x_WljCx>W1D zls8MzB*ZXZLvB6FcA{!&s<9TA-za3s_zDryBDxvsf!!?|NA{8K+K$+@HuAXfs&S2GjT+ehsY5I9A2MHWj<}3j^;}X^PlILKswxntN-ggfK5_maHFn<3;Y!7@ zFN$Cd0`E5T7$r^gjRe2Em^r^3|2^PmU#!0l>97|cJop~`2JAl@?CarSo&W#<07*qo IM6N<$g49C&9RL6T diff --git a/docs/html/img32.png b/docs/html/img32.png index ed749deb990c719fc90a94603bc7719606b71773..33c173d649c7e7c2a0f3f2da16629a7c17e75bdc 100644 GIT binary patch literal 292 zcmeAS@N?(olHy`uVBq!ia0vp^IzY_F!VDyroqNm=qznRlLR|m<{|{uod-v|{-MeSb zoY}p5_o`K^X3m^hR#w*0(UF>(8WIxX?Cfl0WTdF5C?Ft^^iq8nPy=I0kY6x^!?PP{ zK+Ymh7sn8ZsmTcvE(aFpFh0MusqB1?!DPqHx852AOnEAFyZK36>kgKA3<8rAnfwn6 zFEEH_eBRXXmS-nV4WEKqGjlw{2_ARWcT8>Pd1QI&1k{?9ZoIHys}r8a&U0PDD#F2s ztxbxJdBFyLXBq3~Olpd4>Us)lx7$Q{cpVbgZMkLgj_DdVkGp!qj5)VgDTz8PvoMq} nFgDOI*w8SO$Bl=NhljyGN2Bk)8|zx2YZ*LU{an^LB{Ts5-!ElV literal 311 zcmeAS@N?(olHy`uVBq!ia0vp^+8{OyGXn$T*2Z0aK#oCxPl)UP|Nm#soLOF89vT|@ z?%g|MW8*Vt&Ik$$u3ELKqoX4&Ee)v9#l_|B-MdOkO1pROmX}qW3KU{23GxeOaCmkD zB)`?u#W6%;YH|VtlO7vKK=KZTRKtS0*aIg{HZU%;FHcB#kp3WiR=?WB{SR*6_t%+} z)62&5hfkbGNWyZ5kXXzC69(xEPwevz8&@_5HZ?Z3PyXNN*u?a{m6wO-&Kpi9{v30k zgn)#Egg<|J9S@i}KUyGF=qALL<8Q%bv6FR%lZ2VU5o4B392?5n7+Uk|6T}i`96eCi zc)7v9kyk^BIjnZ}Lu=*3aSK?!^X}uX%Uvma@3WZ!1B1kJtryQ^>47tTSMv-jR}?)koZ=e>77t^j_voIg^&orARHcM|+y$WcLxk|uyw z0Ek(^SyvYaHaq4b!-UdepPK%Ir6pQa@Gfr!OXb9g>z<~vDE((oaFC+eV)OybvL(1G zy%^kAmW#(9a0QI0ta#LM>CCaU`%K&vREr(e1Re`ev|0Q$FiTxeIqAPY=q1B-FZ5(^&1xyZs%{Ky?D7K%1>>t|v0nPUJ8R$4Hrz8fH3 zR0SF>*giCqFVjv?v#Qj^auCUNP<2 zv=ePvYHfVc{-TTTW%KDa3-ph-L2Rq+7ZyKy@;#C_yLFQowYCdrrZUACMa`&~1&Q*c z2}Oy^AX49K1nnkt!@KaL2(gsn6pMoGXtXZ+71&Orgu`jB#xKLP+$b~MF(wDi`5Mcx zfc&ZXcA1MjNAW3`VA`{dHpj5ib8yqHxd?hM^is)FvoU*{)R+sYQ@a9>12kt-awb&l zl!#H(j1CFH@?;8BbT!sOA*mjrrMXiRwb_bwt9*^c$hkQjC7kIwY#9%=a8Se~@}o^? zhO{Xn$&cU4%UtX!#fe(6tL@pAL7dm{CAi>Ld|6x=EO{fqZ>oKSIf6QqMW|^Jow0E| zlXq8BGdd*bAeRAB(T)^v3*$olvyk|85n8Lwo7H6zokTRQ7RVwXI1;i!Yb+%8PXPZj^~-Yin#!kj)Jf}m*VLUgIZ&N z0_+r{Y{hCIYUVzF8B+!KQ(?vqxAhR9EMCL1A8-l;%2xKCUB;7dBDO>5iH7V>|CFv znW#zH9#Nu*qGnMI3&Qe5iW?vmsl5aebfWa`b(=bg;+ zswK8bvco@3X)d;c|0u_j0qq#L6<}R|@%>o9TV_f=y?oxgms~4r&`!*FJzHT4l}l#q z_hoCAe=`Nvt$A!yfAN(q@NCr19|JlqYW3NQ{p|yO%?1B1(P458+ZDN{AL!>XR%4DZWkWlT=F_RqC@A%y6j>C8RZu zCiRJbP;Z4weK=u+sm~LcOfgjI!wIX@2ddPkN_|QKtJG)kR;4~wyNB$aq(0BT6EgL| zgwi5PeWr#@eWpg6`qUgx7el2!oKRX6sZS!GJ`^hT;e^tnNPPen=ED75A4*6TQR*{W z9Q8t_K9rCws?;ZKg-m_YGFeoq4;bUZr9PC9KBGx}=C-89he~}oA+2#Vsn5c^Kd-)R z>ca^mOnrncY>s1 z34*?Zig+n}t9xyeL@sW{Hr*k%0^o)^4$mQOiV5DhX2JSXBfo&;FY4DlAo-=)WD!t8 z>Y{B~Vk)47iZ`G`AV|DB`W(`R&@R9&iCo-@ZMs8j1tdq2P{-jpxVD&pj+?zku4Ii@ z;}%Dtgw!R~5;qlMP>LA@;T2T}@!_yUEgpghxs)hYbcfgqNRA?*j>B`rFiJqXdeN&; zqPWI%3Xt))NB~r+xOfl0PVk=MzbsV0dz@%f8z&;+u#&)PR z#;2BXTm~t{5(EwRu7<1Pg@BPuiDE@}h^>I+C{nS*b5IW@DAtQ7)RY#HKu5*AW?yG{ z1X35n#K(|x=W0-7Y54D4Pp`0mkPAW*{7Yuj9bzk)Osxy*I6Q}V3njSN0dMwkhYPhtG@C<_>_#XW5(oh-_6p36MbLfu5$zHr-^BhbNx0^W= z(H%{-#d4tW6eYj8ANxyL3i^l(`_EQQ7vW#|FTpjXO)=L-Wse#O1aUBRU|q&t)`ygwxyLqTU>uYOGCm& z+A4~6ay7y9(r(}TzM0wCo!K8=P7^eb%*;36kN4j9zW3huzBii#=mW+m-aG?*yyHK5 z;1f82|75?hz_Z__(J*BBrQd^rWu=BU<^yxhu#*Rc_?WgAzZZ7)MadM0((mZbs-EMD z7EA5R8V;m+Kwg2I4qETNPJeVUFhF~dFlu1%JP}$&1Rmst;Di)jAnx{&`4HE+6X`U6CoFCV3jP{7HjSUI2|1z>xsql`-v?Tcx(>!uqug2 zOGWMzd5|mT$|^gJL^@1FSXxkwcVH1^>f*qRs8uypZFu%DFiw_GH?k;(9GIRWcrof? zB1^d{-2plk}t$jrVDJT%y_ zlK7=0%q@M`=+IdYelXNa5m{!Io3N-D+C@tFPG+dpavgc~IYUGqpU(F+PbayoW=gj% z5Gr%6S0}x#D~cAo8>O&Db3GVu8n9$!fYbmTpbIc6no&Kf&_rKIU72)>33#AY?6mly zj`sqbIhd|13$>`KN+O#HUN{Ju3n3EQj;Ph)^RKEAd!~5<+@u!No0x9GD@8DD$G;4I z4sggv7X%N&E(16YW{AqE;!h4 z08@BZN1p~spTp}Z-O^yHLx5@eN7}-?uoMTSz0wP=Xn$+#pCRjd4*1NBi@mT*1<{tv zGzKT2A+Ayhjs0E7mxj?akI=qwL~ah5ETEZM3=M3!BndQdv?G)$Yk|iYA-M$WR|G~V zNdZ(HNxO<@YP>dsCZWabA|#A>IDa3@8j8beUS8hL_9%+U4bBz zK_prbWf42UR^-rIu0vEUZ@3)RHmx>+=H(-ydU3a6!j?`W=!A7LiZcTr!w6{8!!+fx z@lu8dK$lRiHYmU_HT&MNI>n>0-Ono(>KgK)4eQ`l#TwffwTsYQXo4!@^!n?#T6s+p zpf#Qi>3D{LNN`X@Sgg|iCP9{DT@2f1PvRXU>pM?awg9yo;nFHo60?WmCy}gq{Q~3-@O0| z9N(1K?8yPdl`S2VzC8wlxGtVG!f1{b`|G3$%rJbR%47$;*C0gi*>KNr05g6Lj)bsazUNw+J)p`y`G^n|(CB zkb`{IZR=&rN1wfmcgAU*upV*SnLwuHE1r(mD~Sj*0#gKpb9T1R(Yh<3we1V#d%(r> z?FT4FJ~aLi+;|Kf#VXACd-&x;AoiD`CV#lXex%Gv)!^j!{j>wyAcS#8Iuw-A(fCyH zsCZLMu~V9O0j7PteRZ~H(WES)>Q1Re$9YX#b=s(pL)55)!oJ65jg zd;l${>HSBPIvoSYt7s>xLSWPs$<&IqIFRZPJGSiBkuc38MaH2g2}7JPqeyV2{ZJ|+ zBztzo%`%Ffn3^xq;U6Qb2DLW=K2h)78P4&w8khxTMd-MMeX!P1p*|zRu`-?mu&IhM zQ>K6c9###L?t<2YWG0QgC{8NRwPtpdSjD@Dx`WW$)6kdRYKjwRWXb4cg%aT5TR2Z& z8ErLv1wC@^82V@NM!|%funlq5sn6DC#EelYnntHRykBW!uPdozm1fK_MkHx^^-!uB zP=zBF1ZQlyMNKv+6E_t8!Pd4~)X@^&=rS!7#+RUl6+R=jk9CDGNlJ?|9zrdqX zlO8qm*g#&&R+Gxr2`-Tk!+JW9B>Hv-l7kPO~OxWJj8%{$2T1k7bm z!g9H)o@A9-u<1sVV7I`eHO3jL(boilTIOC@HRpv|?f9wK-JUj$=qxkpZ?W+(bprNT zg2OtRT#4dr=!i#5jPZj&J*N??7`E@E_np#q8h9SVa{vYVb~Febh*&KT&yBMfL^ye^ z)nuasDP000>!m@lE(k~dCUlu-iVY%cSlCCaV`sc?r-tp)2$8S_PQ!z^ZEN6sgP!x$ z0ns|cT0L@^xbJ&vNm~3ciXKh&5e)Fb8Ct5hHi=#SR$uY8CG7<$E6wV18Si`dH^5~3 z8}Cr?p{~};cmT<8%^TZB2kUV*&R6lcLFzO$%gllcJN%&&c3H0QXnpLIerTwP;Zj@D zTIz6eTXZ|N|8Bd!(^j^+^ok(f;j9G$XARC?=wlQH41H!?Dy?7Wqh|&Teax9O!USs! zePj^VKlCwNSm)3uZY#Y)pBk)d=u=eu!9t%I?|kTUKJ*zB4nw4TZ6`**t4IPZ+=wnG z-=)hS5c_D_MmR>cV^@;f8e_D$Ys&}}cy=xzjN#50Uq)h0d*q(uBF;g2Pe2)NJf<#E z=Lczh3qM09)ruj#BPJv z4t^Hkp*ah7en9K+Qi#N;bq**TxZrV6$L+4;u+o}6FVb}yRR z*aWa|*Z*M(TtO+~YUSiDSh?#mP?{KGl{Z*ancX)RNf#IKwLhFP!I&Bcb^cUDJh!l6 zyTG&axC8J)a~wHrPIOLKnVJT{3{6*mxTBiXumpe7wJXNj)6jy0w7^N~84f z5h`ePSy92Q4MVA__;Hi)Yk8Y!U2g>#S|x&#gWYsW&Jv!(R^Aqqsm6$fUkVV*R)A;2 zY8j<@FyzAtda4acse?_8uxYX&Sp65o4yL#EXduzXjPaqYY|P3Jx*+B$)6o zEu=(USBOO(PD(H%R+w0Qt0jzK84tg@h_~Hk8?HZ28~P*~e0dQ^E6H%};I3&H8XE(6 zxXEE@X$hv5?yxXgx0UII4KOvmvWUo(`RNVp4*fkufodm8MtKou%}9c~nxp%Hl_w;g zOOfo-lBaz6gF3qkwg`D`3ekIv3#`716;E7 z7h7ULGS`wIcH=o{Gtw`Ky)R$U8}SJc8sc~kR328Btm{N0*5H~Pf{X*h=21x5hXpfK z5UlQnyFwJW5C0~Jw6uk$4>!LPh6t*g6rHRwyxda0{+5N`%hA!vf^YBRrQt7#k_PVBcvXA^C zQm1n<#ltETC#++NN2{(&-~k_9is!Vo&MBU~R)FIiP4O596QYyCTx*JF*p(R0%@j|` zg=b(rQ#>WNScy;gTubp}%NzZ5P4VPLehcSQJSlKK#j~z(KE?B);J$SkL_5Y`&zP4r zLEy1fn$NFgDLr!=yR#qZkHk#72b5PJ( zuV!3)JOq^2_}DP+pFkZI>R8I6I7FW3FE0nG}4c#&?A1frI=uTMa)z~e5NEvh^ zwEkql*@HwXCkas^C=HS^X}3XN$1C5L*t)_00Xq`m(}@R@rvLx|07*qoM6N<$f@N5N AA^-pY diff --git a/docs/html/img34.png b/docs/html/img34.png index 75e66a30e60b99898f2d4900a6ec10e6240938d6..de4be8d17f15c51dacf04234012570fb5bd6af3b 100644 GIT binary patch literal 713 zcmV;)0yh1LP)KmCtJvK@`Wo%@E;E^pNgH+3q zem5xA*29^=(~6QFkD}TQinL;&F-M+O)OP(b$3rFtMcPDdeR7UashLU@LpMD!`4mTi z8zh|MwG*Mn`f;IjWXwbEWFh&+e@)9uRNjrbq?IZk96);{&OS)h%q6Ida|>BmBec`A zmQ$YgY$X*Iu!_CjUCt_nPqvq(#Eu_cMQKvL&xJdW)P}hpyXo~(u4xaHs|e0!w7n+7YrHGNF$1lOL0|--r?YXe ziN@j3&E3&BnC9WX?R=onhSFLXdf$$AhTQN+CcU1jYSKng?m%rEw$rULHV!7{dxaV= vU+op@)kLpI_?F$*Ba*Q=9QW_hk4?lsv}%z#!HME~00000NkvXXu0mjffecR0 literal 799 zcmV+)1K|9LP)X30000mP)t-s|NsA) znVENYcU4tY?(Xh0Gc(N0%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001 zbW%=J06^y0W&i*Jok>JNR7i>KRn3djKotM=D@~fD4XZBbibiy6VJYod5a+7mVQ(HI zA`2qegV%-F#RXAl{R_4zsCWwEp*Q12Jro*5P!J{h7sL;C7ZK{4Nk7~)Ym2Oc;_oo? z=FNM*dGqGY3=oSofE5nl5tq~PCNVg{o2<;J^@O4@*~eTN$yFSt_R6tf76u;|vDZyw zb?Wth2`-pu+YA!lt3$CraT6qp8Hw9Cs^>jJ>WoS{0uzpT?$s2&LnMB0tm9C|a;y!* z(1pxFQ5rnGTdho3T(mVL@faBwDvk1;PDcn8q{ylOCr^G!47psOH8|f97iS8HQbP<< zQ*Fg#Q_^1BRZOqYQE_&VFR`BP?dZ(o7Z2^ zO*d_5OTZ1f1Tdvp%&B-w^8QZ81ynULCu+#2dN6rSkd>2W`*aPRJuuLLog`G7TCr6X(1Hlq$P-1o;&l-c{{xnwe_Ecp5@z>%MgKQMTeuiqGc1PF4B!@4wV(I-|T+1rP3;-ilGH4dz4VTXj7j#IWLgBO5 zc8jR2oXOR=V+n(oH-(Q2%|?OLk|8-+ilOBp%jZuDB)cT z^+?)z^60VJs@pE@DJHu9FIkOJrTLMpBMyF)3I~6feT^v9_E5^7rnH=h%-7k?cD0{{R3)x{Q~0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*IE=fc| zR5*=eU>F6XfDqtfXn?a9a1d0^gQWbx04e9jrQD-z0fRQX~N0IJ-9FMxp|6s+7)fxCbqS5|@HGlLKVzX3-B%L5GM42p2K z$1(7muq)^Vuzx&Yyk>9j)A{u$>{6fhQ8AiVI0O=eDXy1(pqvfOKLo zU@!rSvoII|SxgKJAj27$ksV_M6yr)KDOS1CXpv^PksOq7Agr7s000MgQIG?Wy#xRN N002ovPDHLkV1imduK54} delta 441 zcmV;q0Y?6?1I7c87k?ZC0{{R4X`c0w0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*IL`g(J zR5*=eU_b>82N)Q6AWR-KDF&tum|_^<0K;PjULXX50w9MRFn{UzZiwydAf6V(K^A@> zEtx=;VT8Z|oZ=5yII0+#_!&MJFvy%a16KC|mwMI@xXc+m;J^V8i5Y`f#F>%B0~A;i zF1XBLa$sO^frvYCfW#Fx@N6(xz{<+W!0-kXJ_io)fz^Ldd~jjIMh+hC1_nm3`V%}1 zvrx_FCDA>j0Dn8+K?c*%1P6d!m60&l}rXLzm z<$4Uv4GhKd7j7DG1h8>CFe$JV03})*kd-HJ0gYe0x$jR2HORY7k?cD0{{R3`>geK0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*JSxH1e zR7i>KmBDM%P#nj=n7Js@D7*1slii|lGB{12F zD2yRfI}bhBs}xas4a&e{*}?M;Q+M|t@b{WFeM_UAJ1O)>lHbdZ@ArLPUS3{+QH){~ zqxi=n1+RZI)48tES=S@FNFh}2^Zy}CL8sZBl%vy+a(F?t29@R^IJqF{_C8KFxsoWAYe^JEXT!mWjkCa)GmPObP5 z%IXWnhxGEpoh(-3IocAEjm6bVa}bn0j0mrVwZebp2OHgvok`J6`)XV${mdPGr$Yga-*@<$f4CS~3 zazi>Aa!`tJ@RJ`^^!DrQjEE}XMs$TucZT3|DUSdv@f_o>o2*O6usb0r zdz{qlqgmbAz}dp)I$D^9S>(2q$Z1i&f2~5Rb@OIp9rzs2(O<);B-+?o6O=s;F3<-( zPT7(fwIphAn=Eqp7cWuyEo7!p(~swnlWdHZfJvYXIYZ+2`;PW*xpUj!cMzlG{s(*6 zzv3i^?4yWL9&~>*L|yOz{J+qQaw3ILX&jLApT#e%QoK2BMKR?lnHKotIxO|w6eG}{W&LZ#^ClI&);yKOCkm%e3YGB59Y-V%Aj(TYaP$nvMW(*S{viY}<8ZkqyUJ9N$WD@w8 zIjyTZ@wa=iqJLOm#Pc67o<`x7ptQFN{9@}}m(PY^Xd_l}3G%>KaNESIfXKAR!J6rl}Fgv5G zD<3-yluk?zYn4_e8tnF9 z_B^>2yt_Yhs5Z;~M?miDxeR8R@Ek=p#FOjR2Y)kX>lcvmA7QtO zi~*)oxLff`3(wLuIFC@m88TSXd~QiReapaO+?Mm!c_?A`21dY`4$vyS^m-HvI-#h2 zM~G~+9;G#JuN~2le2ko81}GTp(#b~aVZiZ;URST(gfKWTE!((<%m%?SX`Wd&_SUKx zf?7J!zs80oney0<;2<7k>@}0{{R3L=yOR0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HvPnci zR2Y?GU>HQeqig|#MrHzg1%m~{tniGIX&XSIESK0GFl=Jq5P#~!(7|SLiS-%7QIIfS z0p|jS7r_bv9Sp}r@4&6VdVpg=!7K(v1wI#$Fjrb_8b|0f2BxExI~BGw#4_+i sf*t6@V8CDkavu_d5s<~izyMSX0Bk5IMdi1U>i_@%07*qoM6N<$f}dS=`2YX_ delta 297 zcmV+^0oMMs0=EK?7k>=|0{{R4wSl@$0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*HwMj%l zR2Y?GU;qNbETky}ODAS{>8mVHts1JM&!zlJFq~sAO zZVem^S%jhiPzB}+k;VA4%!xb;V3IzFNAaACRE&x??zaxXy06~?Sh&W88=Ce5q)NI# zyS>sQ{riUPV015atRFVG+>+XR;3f8Ld8m_n+DdiPpzUDCmdC%s?nQWCz2m&?`V`-= z>k-GxW_;LD;8t>1hW91k1YqcMEnu93{qO?Zg)XjEoE1^9olM51tzf&^_LO6t1PN2`EEeCxa1OYq1pQzQ z!Y{BLyPNTEX0gjZ#{F=O<7J!VOctf&u4^ul{~(tQtj4?{8!TQxHpv!EYcP2O! z#CIhe1=WL!PvFZ=`m$(j&KG@((^JsL%eEX+GKS>tQ%wF;@{<5R>vl>-otYBUw_~T- z0O{f+C+w=`Xm~&c!K)$(l%gG3xh(9XP4`3k^TA;i!!%fXRS{j}Zk*V;R($X7#w60y z5B#DPLl5{A+vMqG+o=Py`;g+2QjGnFbUUS@9*mH4rIOTJ%R&`%G&;b7pr@%xFA7M} z>>ELkF+e9gjf3DR)>rk%N6;J<&TPnly$@Zk;V{`<&#|xZ7xWiY&(R^p9r$PLaQ$O^ zR>oMeEmy7V9-{aafHPVOrJ|lJj&Ub;8VxY3n7fb5ucH$CwPJ~e2UHM_v1g>H?t4*; zch>bdT}`k4`w^Yk)2|`r-@XYfXW_9qBQq4JlqkVT@zGi^e!5_pxNFcVub8 z?jZNQU-7Jhc@k7RrQ-YePq@8+mEhHVFHCOok8!gomS}iD1>t>6Ippz#iqd-kmR`W& zTDZCwwy&bO7{7n3=K`LT3$75C^}SrMw>B587ni&S6Y}{f+5FWm`5K2?p6;a{IJo3n zXXyp|pC#Y9JUeCnfa6^f(7pmg+`anQ*S&11gIHufpJ#XM+*G7;fczcny)Jytb`(Li zb1LjaXDqX&?}-A;=-YjOo0L6+rK1-|vp&Naf(lA~u!h8*1*J$|OK>wD&!vMmbjyr@ zU}(h$jbTy|cS=JCPB83Cjof24`o5@%#WME?I8n-%%~U6wa-vm!zSmFfl1h~d^2nPT zEYTNDm1=qgg(xDMuMa}jWPw?IE5L^EFp}CW``8(N){teYv=5VNBo?vC%&OTdWZi9j zTG=-J(OWlH%hBimU=F+3npdTLxKzVi3-1`Ij|5~(DD|NoXspzS1F|KQ`f#~%QXioqkX-7M>5NkRAE{494{=hd&w6m; zr9K>x$2ghPC-r8N8!PpZfC;8PcjWV>SgDT$tWh7RQJ)(1DQmA$pV3>5`qb<)vdfbC zJotRf)Q18pODOf388`KrnQZD)zb{vcmHJ3PWl5wy>0)kAtkg#WDoY~u0a)A^?{9rL zAX`GI&-`N$FZJPoY)Pd)IX7nNlT*QxN`1g?h?n|sKz>gq^;yuKofa$gk$^nL$)rAu zi{ZTbKT{tGm|*H-KiXD|mHJ4)BvYSxv=xn$`f$J+^$A*y`uN*x)MxZoqdqmOS%s~L z#fc{2OLcqUCM^g`qUjE?p%6w<-N*@7TVmFlqD+O=@X}ZsE!G0lZ8YnkQawK7&9hPS zsn4n9i2BfNoS}6fRK-hUX`@uU#s9(82X^%w?47*5}gm3Wm3#f{h;Q*7_)l^&)pgkJ)RH#LsGVjLn3 zNh%bV)13g%;a>#F7}L9@e$vwl-uB3x+N;M{;TLhzic?p@v(ETm)o>aY1OiFQ6j#!n z0MFrv5V>%GQj_{eu2zc_%b0yqkTZz7Fn;kpxo~7tgM=)`|H-vzl`D{h;0b{eu`;@o z&*y_Yhb9{0EgaxjufQF+i2#ex9e5Z7C=qpGe{pI)zK!t=Y@0WTuU|qaUK&Fqf}$bG zkX6#1AkXoB5kvt}Ub94Ex?|`zvr)wwa^mKu0-jWYNEkD&Hq1%_d~7JpqUcW0=~AvT y{T8G<0n0kkeUWr0=yWM}5~H=QSe(XtxA-r(#80@|Xzx}40000Ypkz($>4IY%XxefRO!VgD8 z!-vX=Kh&VUQkZ7jIN6LrkQjwG&dJ7>&0?6EowXnT(e;|rrx^0P)Tqui) zXkxI_lUD12>+`(t%J^9<^{4*Z}T}s1C?w z7b>Dj8K@eHb#>4nmw~K42-g|RE&|B*VdRYeAGJsftbmF49CaY@Ug!_nBd{0XS#Q1N z)e8Vc=E1lp@8i_+FbcQ{g}@E!E`ODn1LRS$LWs_r**%#7X>R7}E zJE%%B(z-IYA?s@lFe9oO-9&VUd%M)drkfl}Caw;Yc&)A}QrWe}KxQPlX()MI12veH zsI_SbC2Dj_Yp{e$E;HWg%^rFT589SXn5zVmowR&elO)X^qzS&u@7}-CElp~dxnyeU z;6ojz*h&5#znj+$P$Sz}ac8C^aw?Hp%4EQ(^j<4Abh7zjhI8{&-L(&#o00%TM?6S8Vjsq-u z#QhPt&j5zRa;^dBzO(J6S7cB~xwPCHyu(bJdte9dRZ zCGz-)GK*}BMWRvC`0fB)39M9ZBE819?OAw(Zw`=3L)ifm@c zdoJaBK{q9nU|m>D>d1%&d=<&Dy(I@xZ@3V2?RGoXq5hVgnAA}>Y{GS&i=Y!mv?$gF zHhEM#TGMTEk)xFc1zQA($rS?`3OY7>?vo9CND<%X7V@4Z;uX)eUA5s)E)3l*98exm zH$iPEI6^s12%z>xAjdVp!g$hd3+8CggfS4q;heKCHL*~0+e>c`%e|XFid8jx&Yn0S znbL#rFD?`jVfN2j4aPt@T2UERPieKxG3+f^r!OwZOg^6iKyA0-Dn;0D!W>(oPRd}U zlsaY?;Ve)YzD3UgvI+V!TtemJ!FIPbQ^D&XFLgQwhF8H#R0Sa0(BqIs@ohX{MbTtg!q#cHRanZSJkd_>(7V;-M}u%` zXuy3a;NhDPz)P=dHzAsveG94h8?nL7(W-E7+1`5^Gj&L-)ZN(nF4RlBosMjqs8A-0 zF-9zrfo>z{RSim%5aa`b7F!if1b8@x8lk!Q6jI?^bnR1TCbykzN9wMWz!2cX%BIr; zEo2)hlOf@WMPfnWXq>_lk3@PYUNK)DAb3#wM;mO|*l{>~whNYpm&^xxrK5%R?QA7@ zqe+`%RPtv<7U#bnuH$G|S5oP6d~$X3T*Rh%HI@205CJSwjyn(oHZQ9mhjG|J78_nD zD)*Rq+f44?sOV8_y&rbWlq#u%Z<^rAvonMZ^3AZznqU~Lg24sUQ}@9V6Xn}}Oq(k_ zYbxPcW}SBxp7xYuNClJ_$$DU+ciB&Ev0dN97$29CM!u&EZ;4q;8gCOTuc={7^;V;4 zN7sf%IdQ^67dM0EJ2|c0WYfm`N#I#84aRV-7yK?{+&%e+O4BTpV8!Eton|QbM)YPv zu!Gf9|3p;qm*}}eAb^wC8llUq&>6HKR=kFtEi-r=<}EPgTBE&5Z1*lTvn{PA@5R>j zY_lhwCr?flzbV^uI-_B;Hu&&DA47MB3w=Dg zjWG1lvyI_GpGK*h;8@+sg+AZrb%R46gI-1&`qU#D_6vPzL`E3;$ci^y=u@9K6Z)J9 zeTD@M!pT>U*4sT(&V~qep2k_x{SY~<;O@C+@+`YO-I7`oV@#T4#f>B)AS0|lD+ zis`@TJR_wxg66E#|MOr!!Jt}g!6xOq!7N7v z@ySKuj^t@IynjkAPP*uTif}P%cF|!BHK|`2R54VNOv=nHz)X50t;kcbCgW}@x=ZFG zm2C8a`{eHePn8~Jk}gY~N7ioYjic@xj#s)86xyrKxV%42h6RdTR8KVi)1S?`YFKqB zKEbmOIQ*$6#pJrLz^!y6CaT?At04_O6qX`d4f9E(Ctkp(nyeBK4t*E$X*hecQ3ZA3 zUk*GpXTf(`G!8EXOpJObLGFcZk3n|FF@Wb=7xJ3y^tKsJd)0qzP$urdAy8d7w7C3- z)+F#Fnf$fJU(ASB%g1jZo8%zp8?ws?3##;d1Hn8bA^iLQL!PE1NfWCc;feTVo zeffPVC{59gV}kZ3yb6!K;V1cB@u5=u#^ftjgjd0#h9h_*?1GaO-sh2sFrS|AmH>hT zFBiqXK4C~{2?cVt2AyhZd{GK=uFw&P99ZE`2LwfdI@;u4)!ViTCu|f6+6GIID}@Ft zElbe8jFFr|zYd5QOdPUjn+b#eMx=<%NfFdLc)XZ2*h+^6lPGFInrj_p zA`6UC>%>hHBDk!!!IUiTeqy&LIRvGD@D#utF-O?|^8q>Dwe626L;T>F&`%eZ#u$TU&_q#e`i5jpIt>uE}F0_iiz zO~(QkL9#>}%q0vWNLha2i^;acBro-jvI*39#5*uf>GiWis(+#*7+eMPP<28)41102 z3AT)Y$H?II!6^S9Fv=0WX#_k*20ca?*RbN{?g02)AKD=Uk6;bU4PxlSwf$*i(=QZW zvy-iZ1COjF3S9z^?rWGl>kKiJSZ}S`2B*7d73IYt!y+24KGJ$)jgi(IC^K~IcwV-1 zOew*q`B8w=rz+5GAKncaCuPYL4x}8aC|I8dPWw~6i6$4EaMK%qZSw-}&+2Uo3QqwBQo5vl7Up)Eh>o zEsm`P8`bzk*GOw6GM7jc|A6k%f386Kp_PQ1BzAm)`xM{#ea9MuaEeV4N zwg!bRr=`T0|BO~eZ#WcxT~pvO*2o)hN1NiA+h_-Mr(=o-&vDg}rg-F8xvkb|nc_L* zjX1^gp5^m6O;bGCJ&CRpow?c+kFiH^I6YH5Y7>45qfGG>Dx4vlt|^}M&W+AUQ#|S7 zM(<3Drwg1(@r)GCq-1a^iymr7q3-`IVT# zVJhc2`Y27~Df^q_5m@j80Dcn;=!Iu;B0Y8w{kltIQy`mo=r5&NKtwo{sLS5vfdAwE z*;8++4)*oEAlY3ws;}{lM z8?;1C$4g10IE3v?qGtAynec+XQyV!Z07*qoM6N<$ Ef-4%#$^ZZW literal 508 zcmVA+0I#F&){KEdq|5D8YK zfCPex3Uy*314G5sKfvsjuv8|b{(~n}l>zMAs7=~bDner7#JaJ4j<0>MA3z3CDdY%| zk9P8pbJ??LEjZy45^(O9ILd|4#?@wLFEC5Gai@%bh?4GgLou7&{fXmwSO80^SwB8d zm?J7^vNhhTiVBQ=zpn|AU2`=xV&gZ<`UBYNn_vP55>0BwIM{{;~0iUY7WA*fV^Q11Nes;`uT8}LV`-1dEHPYC<#n(-MIa!2nh*sc6K&0G7=CF_3@k|4ie28U-i(tsR2PZ!4!j+w~`2bdyw9aPF0 zW*J0Vb(Cymn#lJwVWD%vQ)!1+mcov&ZdxCBzopr E02dWJkpKVy delta 163 zcmZ3^xQTIsc)cJCGXn!-m+fk21_lPX0G|-o|NsBboH;WzH1y1wGlGJGt5&T_OG^Vv z-o1Nw_wL=xHl7Lvau`d3{DK)Ap4|Y+IC;7_hH%VGPGD#%Qt(UAU@)|lJdnWTGDY&# znS_RBh7DS*6WGky*vuF={43gF;>|F}@-mA{QAk6pt_(}Up{EW33=GddaOVH|74ZgW O9D}E;pUXO@geCyM+&b9+ diff --git a/docs/html/img40.png b/docs/html/img40.png index e7b8816aa53b682551145982cab79469dfa7e3dc..b026c00d67a075f29a6f4c11ca576e9461e6f70d 100644 GIT binary patch literal 730 zcmV<00ww*4P)KmCb7tK^Vp#_A9&DHud6t3tmJIi>Dk{@X$joTV!o> z5EhEGpodTtS_`rellI^tNIx`s=)v5B2)!|uu^(<+xl?QPE${=6Wqbw+s>B-1ULq4;^ zT3Z%09QPkC3YtfOwE8ClZT}ET=U9tT*`d{htiF~H>NWPTwCfR|oVS`j1127%+fCG(OD+K#&Z)MZ*mq(U6Eyn49UkN#5NQnY4Kz)G z`~~eYO=x@>(L6Mg1YyC&&APFvUh@^rocsW*`5=0am7`5|ykBqjUjQHFLF7KeJX@1z8tdsuLZdoFuhS{F|`zU@K|6LN(D~D#&!p$^S%u0OioWU3I}or~m)} M07*qoM6N<$g5)Gl`v3p{ literal 909 zcmV;819JR{P)KR=;o4KotJ$I(8Daimgi z#yg!3Yj|p6id0#YI`wRoS`%Tk!6v2uwJHI>!tK$r$Xl4jFG{d&uu+p!) zUSWnRQEeI-qc4~JdK5XI8d51i4JTxUp6qmDQD<`=FG?IvRI4>I`Y@(>Zp7D;C6R-> zHhhh&9f_nOwsoTwS{bA}M%nPCm)--KQ}g*ULbDQK4Kl`PKku|-^5aY;d2dHOBD_t7}cHs+_6o-8fH z@=;uvTx4IVrvD0fsZGFq)}@EWUWEARD9$2-qgyV@8y7;F(eaUFrm+6HF@%%6u-EID z#Swl2eI*vYSo2I1Dh2+U?#fV)7@++QXwv*l76+fnbs{5BVtODA8D%ttQ*Lz)zt|`> z5`JpO6Ptadn&Xs+w>v+yodpl4f$0P#aT(XMIMZ}_)poi#gZoRX0Wh%(&L)o2mQka+ zXdhbfp;U63DUEr|w{o&vCel>fEg{`nOEP-7I>0&ET$1+HwY<+s`c!Xs96S{K@u+Ie j<0v8o#~)eO|B!wH`Y6Ogq}q=%00000NkvXXu0mjfq)wwV diff --git a/docs/html/img41.png b/docs/html/img41.png index ef7452395bbbdbcbcdb1ab162eb358781f9b8529..7dcd1938b7d4da34360c115926e9aafa2af0e124 100644 GIT binary patch delta 510 zcmVF5-0*ZntfJj}<0k1YO!-Qh$SCJ3|9@1*{zgn1Zcf zGKt|cLjrbPtt{U$1)<(zd4R($OotfyF$CEIAT;L!9J*K}83GlMjAvk&#=yV@WpcyA zf^%tEJCK;ZVODrX$+Qg&4iLLoVG7v#7#PYK7&NQh4m0orz05RyOO63Ua<4)hLvj!2 zF^fyA&lrvZ)qgz)Db|MDu3x}#fPrBGPs0<=#ulJ03@7*;7y`C4>(4G!!DtROibL;$S@n^VI8jYswa%%IR@y>~DH6r{5l6czYf9K1p!P(p)& z!4VjoY#UZUlSMXH0|zKHnU4j4f^<7WECWv@^G87$uq+~Kcz}|e+o~eL5yCJ#ed#2i zvl$qaKm^bMOh8Y=)gsarNRq(_CdI74!a!F50N96E=r}~lp8x;=07*qoM6N<$f?~@Qol>XP!Rr_#HLLf8c;#SAryxy)V3hvW_Brb6kMW97k|OJIER8FSZMGsDC#Cc z2DdKRT!hBKK^$6lhYAi-2fde6+tgUGIQc>D?%mJt-U~1QqYOxih|kB-w`SQ;O6p)b z!+f7TflQNB7}KZ(h}~l zPmjSN>4n57aep$c7G25g^|cLLdX;F6z~=8!AHLsrphYF$>TpV*7JafWrdr^c-b9V0 z>H2PCDCYI7MXo$Mi!ucDU=PX_Rr4HpK~reLBfB%X)4i@X^^#){B~fdb2)T_c7&fWh zsBfg7z(2y$C`G)+WFnbNs=*1|!tz(=oGY8i!3eH;z<(NhOySc(VtczC{;bi zOQT~PrmJUU0!Q?Y*!qYk7J&;&E5D?`E998Ulnu0VC}O7t`6i2XOajpwh4y<)IGc^q zrS3*yoOn}nPMnfNJyM7k+F=#cQ80U)Pt#1^qf1k^=uhDdtUB9tnn7Hbp0H7`voPPQ qiWB2VVo10000F5-1&V^GfJkl4WLd_vfh=tt0bt5w2kWW=60~VUb$>T7Y{#L3wZi~YuoXh_ zBrtr&p{gYAA;=E#8bfSo)B^0wUl z5XX?*!+Ff&5`XJ6hND1*&q1oS;r8nnFdSfDn84HU#6p6lv4Me;;RK%pL%?>191y|E zUBGsM;R!gDfxdYb3IZTMaU5U=+U&p=0P_aJQxNqT=wwj1@*8k8usi^}2t^ySC=W

9 zl5<;CqymIHJALUSpwk%`lt2W~4NO3v!xbZv7)X-A2rk8}z`{Uh003$ZTsei3SAPHi O002ovP6b4+LSTZ4l-x!D delta 560 zcmV-00?+-J1iS>07k?N80{{R4n*24t0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*Ix=BPq zR5*>*R69$T>RkPbMAM~^WK{P?_jLM7sYr37o{=pxKLMv_vQ@4 zb$S*PS5T2e7ldZEU!a^gA4#A@Myl>gJXFU1O)Y$-HSd_7}Q zzdFeTSe|%-aetBk6Si|rhHakb0Y?>2h>g*HT-o2C_<4V=z%JI0)ieIen?^%xaMqlP zTtb0n$6|VK3WE!l?hqxhH76skZRjV-lnp+nAQm@NI-(xWb0I$i*J0W~o(Cs##;F|^ z=pf^gNcfrW_Wa*5^((KKQ5MSK#rA!3i|EMoM{=Mdcz+lDEdt+Q&Sui65~PUXb587( z!n;SLuaw8xL3<`UmfOqaiP>a7g`^hlE91aEnXNw!;Q<2C*{vrR7yVd{eRqdTennU*Z*+&uXEyC1rO20000zRuxfI(=%X7td}k6j?>O?S=b=Wx6H5<^1Z!tL?Q%wDfz7cA6^9NSxX57k*4UYy z+5SS{A2u0Y9exRkQ;KCa2|scku&4Ym{Ge7~VzEJdLsN^T_=dO{2HYoR99^*D!1G5B zM5P#op6Mmnv6;+oOtf~^VfI(~?CvNz!N8cgS%~?>el{K-9*5_Rj12i~nrTMvTT6ld OVDNPHb6Mw<&;$U1G<1>x literal 320 zcmV-G0l)rp z?O0u#YPzndWtCD^JWA`q*mdiomPT=Hy`Xr|f}-n(df?G`v?_=!LhBb%sjF6~pjK(Y zFFwcn&Q3BjN!JePNb|6>nfHC?IsSR){E-0&vs>gN7dkje%XA%w^VukPU=1`!k&ddBZ;2fo>8@GO*q6|e> zWmcod#4Kl-?^~0A%BD0{JZ)61TwP$r(#re-!AiW zSo_&dfU9qJVNTC3fOJ(CX!X^5WDcz#24m<($NXl!%RT8G?>b6wM`GAqRbC~p%1SF<1p-kr{PL;akb){h=O4va* zj(GqiOoy{ne0%K<8*W-up%vF6&koF5!p{Zvpns0{z%0khHr<&aO22@^Ud>f7$6=gH zUQkSp>3&K@gT?{4get-E@|77~tk|LwhrFrfXt+Y9!osd;dZ!{qKc)KEB{v4c&^uzF zv!~c}>*pAwq&v-Dog%uN$Jd=H&J^Vfd55#n3cC-hC4I#9DbCD9A1~X@kd`^T754cR z|A1c%MY|v1XWdV!XfRuajy@brbwb9T?u6~t91T~fRCqxofl~BnPIe1xU(dCW`DnbU zVmJ-foN1$r9F0>4)`)LeD=sU=*#V^(HiJ*GMV?-^$93SvLp6%4N->UquKOt!jbMbl zE0v^ot_oGm(P#xrh0Q%Z`lf&sop&ziIR+Sj$8Zun#d@!P|4TGSg-dm2!5T%ESsW&} z^-1v!C|(EX(vKa+qpp9Bf0sFyY&WZ3<1g4#3{m_%z%N<~rJ|8sl@6FP7@e@t&M)Wk zr%{P}v|@>dD^x1Zv1g=c+Sj5OkF42vxtiPf%mu4(#Bz*LbBuO4`r?bqw_b7jl^&PR zTwoddeLIcuqa4SQt;3O96LTi~P2Xv$PVvHG>Hw&IO2xgQBAh|XB%%8?C4m^ZTRUG7r01xrUSj)sK* zm5MQLC$V_t5Jh@lf(vl{LRxuQ_sk0jhBBULj1(1dg>>}e1%`dYZK_?A15^_%#xT8 zS>ABiI-aM+$)##;u{{5_t!@7gJ1MCTA)8pKPifE_NF?t5o8l1^^umcBvKziHZf8kX|W}g`Y^JIllpLrEuqwh;YFO(M`#Enm-;ZWiIe(d z^%N(S`Y^JIllpLrETPm#kWGx#M_LJ{K7wpwq(0JWQy*wkpEmWW>2Fh?$y=NHwCyCa zlal&e|5VJ>hXN`~DD_zoH}zSNZ0gf7ny?m-ppPia&O*MdPGC9I#D&g4U)!{{A-gnY^{BPutoS zX1B!RR8dQd4Ik2ipd^y+n8S2RB0v-ZDjJ)9gN%)7P&fFliLEobSqoflBU#5#`Upsw z9;ERuwow;VW!@WPplOih$kJk)lw#v!x})Ql!8~*Iiq$xg_XZhg8iY5$ytLRRr8s>$ zTvL>n!GfEH@hP8?lUA%~(8p?Nh0VQpqk<%U#R0nGL7m>c{SV*!DS%CL%zy}we`Yri z9CTsBo~iFZ_B;KX56HgflwERT^ui3r_a4T5vD)Y1Zz%nV8D6xY!m{lL%9 z>ZEubOekh{!-_4zArtYpSESA8g&0h|Vx~bYRE%@1AxWL$I=WM@I6Gjfp9S$8^C$Mq z*~!~_SDMr*6+Op_!T8=F1C5tjxmUwaFk3;A8pQ#+Q?Gb&Pf4AGu!q@=S?$3q)cii& z)+EKk1wSZCR6;MzV0>q;lEzCdJ##I&%@s&O@Pt5#Qd~!OJg7rFX2n-->W{)1AQu|+ zV|HWgufT(2(~ow+e4;FZc;F6{j&6)zn8EnoAlstx5`3bTmKYHf4M`>}KzG7T|15~P zO4{p|aEy2inAk)DPW+aLjA@WjmE}ZQlbZ-_4R3~{5KqwQ1l?u&El795E!UvTNW>F# oIzdko|H%fMZ*mMyEqq%17Yk`PJ=eF)0RR9107*qoM6N<$f~^)>$N&HU literal 4024 zcmV;p4@dBcP)mASac%}=8LO^@hDoe{IS_}9n6p2yj z2W?tn3KAfYItoJKT_aV9x28*}(iUmmP)e$*TDPhYP)aA;2WibJ{($h5;x-77q7;L~ zLqfo0A%SSynse@*mp$XPcjMBi%1Jzrd(ZRUbI(2Z*b6WM%rD}_W8j15;RC(+0Dc3& zeQ*>lST}!&2%vD;#j`&F6Q7kfUQ`QI*9wt5C?#q1h(#Vqb>3AOMvd^+-DR0q_C z2Tj?fjZ_WAdIsJY5_X1THAXW^fdTAJn*wB%h za2l-vU>R)y4io~70cr^zgCerwmcfShfV-)YWa8>VRkRvRQyQK<4Js$eU6V;2>I&Vv zrc|Oumpp?LsN^~qgWesY$N0eZy@`8TDA~=cE;LTntM#YJ!4Kvo(qHJ3C$$?wGIb5` zp#d|UG=Dii*50jY)gIBWPSv;ttES1+3aj8~dA#`p73!esMY~af(T-z5O4(GyaPS81 znGRv}qhQG3V3xubHjfKdELC*4DtW!%^kIkSW)v1M9{Pl;cp@OCAR%&a#ZL{qkF};p zK!XPYLxWTdh4T=2FsUO3-49XRK(h~;TBM%qu7av*`j-|F?70|8@C7U=N8>)_m{{ns~h`&M2ZzN)zN0so@K%0gXMw@52Xq)K)J2UV;de0dP zq{7$9>ELneJ*J+CFW^<;T5d~XbPKHkmU!uktwhg?^C8@7?!(pL-g!T(sAlDFMMZID zI%quSDiL!_Rkmr%_#1m376Q)>A*Hcm-DfbM=7=Wdpl?@4FqmDT&zUl}kR8`HE<>#X}80Q?^(t8f7zj zN5dH^GAV%OxD(3pOt8H&S`rBsXb(j>5Xb3UaxS;qZl7A)}-G)PmJDdkQ( z6}Sj=j&I3x0IkEMvt`3*jIkh@mA+_#aV^&Sb00Q{!&QM$+$4YpV2p4sjaIG)EB-Zg zaiT~#7gHZ+^m;cO3D>AsAe5Zsg)8xhuY2NrxI+pc=kkS|VuPH^$0O)UELgc6FAv7- zLU5uBK@Fe4wbsXAuZ8B&Sy81`a^E3|6ySXN58`Z9;UkcNtKs=HeEq1iF!* zbC;gFh~%o!sfs+Sg69A_qT|+^(~(MOsG|w22Mf-i@)SkUWK}VHzK5}ou|Vr!Iw&0a zpB8zv8o34o5kmnF--G~uen;GeXkOtDNG0Bg4XzivDb`NB_jGD)$m?S8IS&ONqvP%_ zLTr%5m?KunK(7;yDuXH&1jU4)#ded))sJi#p?ReoQsG;29ndhQw;g4mbXQGbNO1d} zEq4f72+7@*42fc&!h?t6*?tOJ-cseI{)UxN=ZNhT5MMgrz|Mhf=HWqD&$^*j{4Xkcwsz^Y$1L{WXP;dsLLWCs!UpvdaL}IRn5=>+1hjLv z!U-;)Z}_Gtp+0PB(OG7P|4uyZX{V72Xj>`xqKtct`ug$}3v+y2N^BbQws0MbhIKf9Q0bem zCS7r77KimNoh4n0jqpHH@U?VbmI&aMSSJdZP1@Vba>X+oY?Z_PuwsLywmR`9vERSk zD)d-OeGDp}T06w74Ytnls9~uObw5Z43T>mae=~(4!R>pthhSyGc!|J-@=|v)Y|af{ zywt}u-0@N$pDq(jeT+h9yws;t%@W+#wzbsf!=i0;>SNMvqNz_iq2Xq!56#E~Qy*3H z$4hLi?Ph>yPno~amp^Ku)3@=1TP~k^#yUW2M6K3O@Z!yd({e#f(K>Rrbw0+_ z#fdDYbceojXTi7GZ4u+T4z|5Fz^_yC!1Q~gF~THgTQz|$=yojFY9s|~ieTHNwu^!o zaWTGVpcG*`pl{=4dK-dsT)BlaUpN<~JBrU*8?3jcF0LJ6kKlS!EuAZTy38@Ss)uHiWP zkx^W<%2B-Lo55>7E=`(OY)(1FLq*=uPIdk(*wc%vQPc7M{GxEXEAB>GOffsf`Z!&P ziS7*7YNWw$ggrQL$D{XzR^zU|OuUfKYPv~6rqVUFdc&LuXIBC_|gX+C|&*M&(VX{ zmBTnqr)?%SnJtfJPLuG z3?hT`obo;5POj8UrZZp=Ocqj6!jp@o{m(Y#^p;3C9 zxG^b0$chc7vVpp4k#9NhmgSdYE4m6)R(B<`y%-MfUxeJjQ#Ks!%>rw+Jhk;0o^>np z#=@>0bFeT6<^o?>oLPm1R;wd;sb4Vu!Hvo)2_pOV_jWu4+Wqq|H9HINY82aQwUqat zxz54P*W+jA5Inv5)T(75w|u2SR>FJmBSfv^+Fc^kNC8lm7cWEPXsE6um)-@++mRb; zBt?)c*#}E0g9vhV@NiAKFXiM9Z2n^=y+7j}c@Q1;vqNpPsBvJ(fnZkNvVPySW!N_X z9utG#z1RwzFEGg&{@4U~Obmw1Fs@M^ZrAt}y7`#D|6l|sE!|q>xHZZur(?cg)OfSFlhmLp<U{h z>}-ZIsq}`KX%7lNI7Dv}W@a-pt&M~)ktpgR4!%?%f5%2jP10dzS(1|oAuI07RV9Vi z#@YR`sBK{`oj=xFLG*UY;5D4#k_}DFMs=4OM8UIyel%$CHNCSkmxkTOpTQ6e=_??# z9P`DmBSi@(0L6-tU~R*rF+MP0aIR4l>+UkIH4vDo|8r~PTUv>5kgkb z_sNt&1RoC{GEPgWIiI6dF&vKfzn)X#F+$WhFrV342n&4a^RTjN4YXXmx_w5Ty)$a(kzywrhQ`qeudlP&Qq?R3JP^RdK(=eX60mUz^<8mo0)mUxc) z6E5*QYX>~e(-KeNaBAq}U~ad>V;+_q&d(B$-i1eCk|myUQ!s?{wZxM@u+yDri6>v# z>0c=EWWa?I&qU!uiD%1@Z;ZwnO=P%`{yVW39vEcp)#;r{f}8&%&_*6tWa8!LZZ3$3 zDgob|t=HslNAg3~*9!+*Gx$1K5P$Iy!@I(Ve0Nhhk|^M-I5`d=sv0w6YkDrAwUv5M zU+FVAD&;&1FB1*ZRKY3V!r=*7%mL%G;dkMlEYuLK@pl#a2B|`Uf}P>Arb7%PB5C5@ z@7clIcD`8OI>-`>sIT-HoG9f;lqj$8f}ae`N9X~HcnJ$AA(Sjj_E4QgFpP*o3@>;) z_djbG2ecZT3hFC;1}926($xkH-q)i)5%Hz&qEIt!b4;(EL6dG2`Mdl{@8<)qqNYO( zBO)=wIcEAxS6t}5!79$TWjVEP$a!rjlRgOG)St6wuYDm8b% zPz5Gk{ULF>=Mebj4@sH9NQc(1FKUSAOr>~^1z?AoEHb|=`=j~!CaZbA_wQ0KR>!}3 zqBqnQ>_8-s6ue6f;Ij86D6t&0Ur81IBo)$arj?w5L>&lc;zqa-LkV7uo==H5SWhzA zeltunEw$?<=)&vxqskNT4$LJJ@IAITW7u%>V+>tCJA{7)$53B@MIy7x8#aM0RrIem zdgiwegH;E<2eaM3hid9ouCAPY;Fc#;pKzI< z@)R)UW6Py z2=>sM6xRyHQl#x)&^?tR2su_LI4AKCF#ZAJ`WF~$*%lG>&C5(T*;Y$op_hIzkIDDm zmwE5a58wp0I!N%~B;UXtAi$cWSpf={r$@bH+os{sSe%nn2!YO5`u5IP;Qz>JwA5rb zfq+fK0m6nM@&zu~l%f@T+YyNR=sS=SVts-LJ~FS~Y){TWnylb=fZ# z`cXf{Ar_zyS^CbQU^}U{ClXV*1$?1yPv<%RG2){`|C51(%ua6lNS7#BZ}B77LsVc_ z5Oqbb80nl%H7eF3|7XpVIwy^uGQq#@$tA{*AcUJ*BiBWm9k_3p$JkP@lN^=rv)yK! zjLQ9Z7-*G7e)Q>ASIn$H+z#;p!B60~qD54fzuG*KUWo}N*JB82MxG{hgQu4ubk`LfUEcd&O*72>gM>=}k`M1iHJZ*93{bzg4 p(AP8uO=>6~c2li-%Ep}^e*v@of90YR=e_^{002ovPDHLkV1i;gGpGOn diff --git a/docs/html/img46.png b/docs/html/img46.png index dfafa7c95afe8b26bacc5b3694058e50946bb020..8d180c6f791acce65c48123148d355502bcadc87 100644 GIT binary patch literal 403 zcmV;E0c`$>P)F6XfO4>a156pfSr~w+0F{3Ltd8k3jD-PM=N!PM zgHsfz4h9aaI@}2B*np~|K?1IWb7@&SkeI#!#PH09>0m8D(ZOzT1Fj>vS0Roexrg%r zh>^e(0M((5>M9L}QxFy#14F=eh8z$9!nq854iFve&q6^U0H&iY^bVNC-UH-(X6OJB z5QZNERvj!;L)So9F+k1(hR+5-0>rq+(7^(Al@E%mfT$m?gL47vg$bMsKnx}!h9@pq zeLk6iArY>FyMXyv0Cxe1!Fqw==mgf@A7I4`kaR>zFt8tNh3Q~sU{C@PAgsW^0(Xo7 xYJ9+0G1wy!1)%6)U)M~c4x+#Y4onuU0RWQ~TwL}}oecm0002ovPDHLkV1i1dn%V#W literal 476 zcmV<20VDp2P)2T;GDq?Ry%-|y4L~(Mn zmrw);p+j-jdkA$D@i+<{oJ6+{jvbPS(9!dg9}^R_LO0*x<2&ccbMkRQfKoi0mua%F z%am*bkE&&5CPJk|IrBp}>WHB7$=U>>2=(@rFVYDd`k)6cZ-%huI_`I2SxI8$L}!vT z2z(b|hm+QL%mir%U{%wo(-tx3V#2bLgyvwS{Gmw#1`<5u%(&8gv3HOFO#(W!U>FUt zHx<{#(A<)scc)?5w)(tXQbtz~OYd+hr>Y(IKlSMpm$te%%}cxQkv|~xlF_1>5$#44 zmumxO{UtuVps8_OG!8YE87CdHXWAZ2%h#ycON{e=!EnPyAiLQFFuKI+esI*r5yF6XfJR^e2beN|v#H(^p4klS6(G@YR6XnlH<0xt_bS9OB=>M0 z05KAH0z!R&f=nAw^=L4hLe>+oogoKAfN(AYpF=16Qq(0Sx=M% z1N*^N5X+Q-{S(kuW(Ec&5COsp3@i)`4h#?uO8h`sYz!Q|3hWrMi4IWpOl#r1v4k`| gM1l<*m@GO002~%u&<~Hxp8x;=07*qoM6N<$g3A@2p#T5? literal 498 zcmVh9Lt`mn_4HD?qj?19b+U|7h&{FlN014yX>k{-t60t~7}7l15a8hpgS@Bx2N oAp0D|YEoiZr9nswnjZ220MaE-Rasl8^#A|>07*qoM6N<$f?^ZNq5uE@ diff --git a/docs/html/img48.png b/docs/html/img48.png index ffc914618dbf09bee8680bcf88cbe53c88d8d5b2..749f57b78d02e8501ef68daabbf207e35379735e 100644 GIT binary patch delta 465 zcmV;?0WSWS1mgpc9De|OP3KMk001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCC`AVxCNztfI?7GjUedIy`V$UQh)Ab>vmn#Q3t`XlY&!F z)YYF5&>!GWF!x^5q$-W>eTU@a@I2w%lK{gEGbpKFdJ73o+5FL3s?x#EsU6i)R~Q}! zD(YV3X!7;C0l$yQeRIf2G)L$lBa2J}%ly6>0;%>n3}C-NF?F=~7;`F(dx<-%=L*5j)-NAG4+^RV|LG=Q1Y=G2uJXl43Ce3lLoekj-Ch<3v z;*MGZX#*?Hwg-%(-^nt8tG@Qi*W`ug^+AG~f_wl?xn((cQRY6-9H*y*+e|m`ZcD#U!3m%c9@=y%Y-*U*!y} z*!R(uU{HZiTOA}uoT|bv0-v0t$&Lu)7lAA5e^g}tiTCmeDaBKI?tlw300000NkvXX Hu0mjf@y6rV delta 518 zcmV+h0{Q*p1DFJm9De}|O4rx`001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCS5dPAnm^8oOrGkeL4^~CY3kZt{>di+8zJPgzP$+^3)_(`^sONy<)ga=jVDKU$ zQtiouhu}e~;LmQ7wrLy0;!Quu&P-;%o!Qyh1qNUQr9Hrh6I;=so5FeO`i&enMS%@9 zKwx}dc9|*UPyGgADnIB)Jd6R{Dj-tJl`sLQc9_kNBO^x`2||!6D(ZApir^ZJ24q?b z%cqH4Sr&9ehJOioIdq34W%(n}I!fV?d88-tdYDfgPnHvBp>uV;6W;ATaCD zSPh%HQJQ5-TCI76MV|6pH|efr369WKk_By1mXkmsvY@VafUZB2pR8p5e#8G2h2cBC z`Rer9Lsxs!?5av4IH>oD@`gPoH@f7?HX*=TAploxSAQ}b!)l>v;}Fqdo@h2DP*Wi8>D2aw@&XR$vFFARI zfiHsLunM^qRGJct??7UsDD-F_LAb1iD}yO+r|Jpz+z}LDt;5>K;MT;o0ERM`NK=_Y z4cQvJqvdry9&r^qHKYhm%9!< zex}cvAUPn^lLQ{%6G7Prk^`por5cD{G=pu1SG6gSD~@{>hZ{YpfG~uDJk^}6^%2%p zk}@P)@Q@u*VP!#?W(>C@dG3X*FcpE2CG~f#a6r@{6$Lb5% z7ZAERI2b!RxmX03AZ{)h#3{pFozy4r>QpMI_vS~_S__rB_(9G+=R5cOTyhTZg|ZYj zgI~fd>M^C{+@HoNz*E15ftbn^4Ys&UQ1*d>IrwrvdUJAD%3a`1@NH4GCGBhILLP}a zjUSI2NLOc*&UXf$~b=6@C0+*uE zNCqw>u;o}ZX`Hs8u^`C(uP?~7b->5ckG;2sJoz7C+HoqsiPOCj(?<_8#0s1Y;NM@o z9^32lYlmWd_VbC7LxFOdC|w+jqe!z0>Oxy)c{fs~+TAAVebGAR@ zY9P;IFTIH{A?g;-RWvzDxO4RyEIuJqSF=FEL8x42HAtEHWZ{jpQ_O%cG26=Qa{Rn( zE{kiO=gQOt#mr?~Nk8v)aus*hrkRL20}gPD5#UR)Xx@wx(~A!mk63^w4#^_`0000< KMNUMnLSTYHy8spd diff --git a/docs/html/img5.png b/docs/html/img5.png index 8960898839f77c9c621f4c715850fef1cedf1c2e..c7e3b86916935ea7bc824b3b9b8041dffb55ac53 100644 GIT binary patch literal 191 zcmeAS@N?(olHy`uVBq!ia0vp^+(0bP!VDx2AJv)xq_hHjLR|m<{|{uod-v|{-MeSb zoY}p5_o`K^X3m^hR#w*0(Ge07;_U2fWMrhMsMxJ<@)D?&u_VYZn8D%MjWi&~+0(@_ zgkxrM!U0AL(F0S~F)o`@Ej?q_1YV_?yjBW}+z+ZuW|)z5n_-!S)BzEHhK`(VtgH8L nV$n(KI-O+HpuoYgAc(C6F^BXe%3G&IP1?QdF@%$Br(H7A1CiQR_R vL*|;7f#?U8LwETES$2PB`Ociw)6B?lr-xJe^3|etprH(&u6{1-oD!MG zPDN2y7x#dE0KqR{a@W|@N^QFd{vns+x%+WXa=?H7SfoRmx$KWt5X$!_A2Fo%u0;D8 zF-kwI%>5$cD&!aAx_x0GMLWwQ9fYFhsqn@H6L%eU^td^ajZ;}j9 zagQcr?Gk=I@qZVPblz+32C;ks1=xzvMqy%i{@x=Kgit8Kg%CwRg>RS_eAO$^ zrVQk9%8~F;$~u*xd%{6#yEc7JQH<&Q7H)RZibo!=n;eN!oYh5F3L3`X%@j0vq+qws z(4OHZ AvH$=8 delta 580 zcmV-K0=xZ?1l0tP9De~N5B5p`001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCOVmkxhBx=#-E;Tek<^aJDVoT@_G-e0?CTum_+#DC)1d323p#bz2!F)*s5@p~*ffwiWelO9tAhoG7 z&%Z+D=`zwOpnr!zP9y6$4z(1`+;obZ3x#kt zr$tx-O$L+0$ayA7sQRV> z)o?eP9R_sBMJ(49d+y_Sh diff --git a/docs/html/img51.png b/docs/html/img51.png index f6335409c72526e4b20d54dac87e20171a8e8aaa..95e38d985238afdc9b3e61be10cbb61d12c27120 100644 GIT binary patch delta 201 zcmV;)05<>g0oVbM7k?cD0{{R3tybDb0000gP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI$At9lkR&W3S00DGTPE!Ct=GbNc003M`L_t&-m1AI_ zH(;8+CC32H<77C&>j3AmFkD4ZDuB#mKfuh;#=yXl0ODkGH9~MOBr!0sDS&vh)0a*{ zC}dV(VPG&~Fk)7K3+-gs!94-lEEFfXqVNp1ek8c#sXC{mIV0)GdMiEkp|>sc)B=-NK8#mSRkIT zKH)<{vD02js|Rx$_}X$gN~cS6F1-{GIZn5kz zN)xkXO=DGNQx-UWVPSJ)_93pesS15uScp5U`4WNr8^c Q4WOkAp00i_>zopr0F=j1;s5{u delta 241 zcmV0e}LK7k?fE0{{R4LJX+Q0000jP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*H-QC?HA|kuHyJ9dNDgXcg0d!JMQvg8b*k%9#0D(zFK~xx( zV_;xl-~{3X1_(I7!0>0GBwP rpvb_Uke!f@P|HZPg?Pbk1lRxoeh47@CQr#I00000NkvXXu0mjfO-Wz5 diff --git a/docs/html/img53.png b/docs/html/img53.png index be2cba0ea04111fc3d37f3d1edd410c14338073d..08f6c67bb8d151c45ba01bdf8b383865ee4567da 100644 GIT binary patch literal 389 zcmV;00eb$4P)SU>M?ny(fU7YA1-rhhO2W0}Px7AVw^HbyI~IIKhk# z{OTsWf~d=Q-Nd{mBn1NYB49Pv52YeOs7?OJx;uyFU zszH{3Kmd@z$)G=>2&9bl0z<%d28QPhvp{qX17E8VvU!{g91kXd7#s}@44)ZTgc!Di z=ne+9iNy$dI}WXa|Q@N_PR1K>`efvV^k>MT)@C` zfb{{8X1y@w3&SQ9?=mnXDuB(4RNyXPU|5!ZErGj$`B*?}WCD^hiysCI+z_S%12f3~ j3d|r{iGkSxTPOkmwi!aS@|7}f00000NkvXXu0mjf)_|9V literal 415 zcmV;Q0bu@#P)ltk70000mP)t-s|NsA) znVENYcU4tY?(Xh0Gc(N0%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001 zbW%=J06^y0W&i*I9Z5t%R49>SV1NR4B^c`)+W`dzIN)Po;AXhSaA^UM9l(GDcwh{m zV)oY;7#NfoW-~CbY+$Kozy~-`xonOgfdxzqH<*|>8QK?s1^F2h@S1@R&{Q)iFrYgY zXyyi>6B!C-b6oM2=4NnXU{X^0z`&3{0ptNDh7A)qnHf$)P2+9=xs!!q!$t?*f4mUE z2}~rph!D`(%fM74fN(5Mz^U%Q0CFP(qqY)%&;Jz+NsYSvLjQ#r7%u+*fUIx=R{)~} zm^Fui?H@3D7O*{FYi3AiU?`TqfTED$6eolg&&F_qf#J6Uv#diHgCQG71OEmFP`D^5 z>4R(rMr#N};R*q^13(wd=<4S;U|27}@xRdlVIKc-1qNP_Cjh9SII64@nJxeT002ov JPDHLkV1jhipVJWH{@= zwdiQ?IDuyS+m$AG2LaZxVZ9m*JI;B>sr3v`6iRNTfq!QF2KT2K?zF-GX!8$Ihy5_n zhF?Low#7y-YprlS+SoA5@nfmx9`Zwk8j_kE#!_N+#0C;ll4ti4F zddiNsn13(kqmZ-dJ@7QtAvSD35_jps6~R_n1L#m;GvzW^}YheA& z;hN^zOa%K>8GCoL}1c{xA~{Gr8VIxhz+o%}W}E;D)AU+I*t zYjK$daaI;wvj1 zgugOQ^VV9z&gUdeFqg|6e*A^kTscF`8#9SUnKW_zcU}YQD20VK( zm&=PE@`g}!srk}e?jt!goNisEJ*2tZM{;P`hDwd{kmfQ$a>3bq!Fi=;SZZSrd4Dbw zBqPJoHujM3vHM6SFWJXQwMKc!ayddWF)TM>iT04>avYUI!%z3LX%A^G_mLbL=4yh#c;w|B{ z;j-bf(FST}xo{~{F#BKrE8b1l-WhY* z!%g;3y|aMJ*Km`a(mTs=d4FocT69IdvjUd~_s;TM7WK~3To&}s@>~}5&hlIq^v=>; z7WK~ZTo&}s8eC59oprg)_0E~V)DU^|$vWlk`!Z8UkG`g_VKKC`!u8%*?+1%c50EW+GD2| z*{VHuT3}Z0vC{&xVvn6(WGnXA>48}_FQ*1(?Yzw5Ih(wU@SG)54W2iJ?$vm!p~QIG z*RWj1d6~pp%_1A$rWGz~^oneJn^w4}ktnhU=VcOa1x2>>ZCautTRtxfifsA3EGn|) z^YY*#TOltGF0$qGvMQj+me0$ABHM6TONPrvMn*008d<0{{R4@aXa}0000mP)t-s|NsA) znVENYcU4tY?(Xh0Gc(N0%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001 zbW%=J06^y0W&i*R=}AOERCt{2Tx*QnRuw+>cxOEikEhEDEszq&O-b`;b{Yw(LaH#S zLdpdd0t1qn#iQMIc0Q^krP6tohfr4_9< zX{IZFAQcIB(}tugy4;5!*B-xSydkUXe(88T*XN#l&pr3M=lI%NfB+PFtlGyCK*PQu zI1&|405qt%0%00L1;mCYP=JeG6OvEN0(zwZxnLh{4KV_^Rac+{xmv$~$Y}sr-!Gtf z0)hcI_Y0&1H42gT8mu56B2dQ?hBr`JzlKnO3NK)SH(zU0W$*qeJs7|lE zmbSVJzPf_S@awpmHaEsqtwp{obOw`&uRf_=BF*CuswPz5pxgB1s!!ocB`tMzQl$<4 z>SYa|h$y-90JmUifMDkZqYRT`QtSBBZ1}5_*3}KPdNI2BYlvP**<{B({fN2u&&0M7 z+|@}^Xp?g{vE-llQzzqY1(c*SM-3JT>g*{k*m?yw%?5E4xvjfvMJ=Rth-W%OFQg3H zZU$N>w%4WutrOeZnOYCSWP=>1f~`M@Kk8fHANe{td%3^$d`NdfP;3Vaa`Kqw{CJn? zpDa3)T2ScpC-}^4n@j`zOSFPYhDHP1UUHT{r*-0XMGCb320n~cv$Wm~YyB0Q*#6c@ zVU>(0-@4E!!&KkQO^;wzJo5I+RSAy#KK#kQ8yI=I){PI>HtH*B0PJ-aRiEu5ZT+)8 z+eedD+8Ya{$SZD2CQAqb%sC@cPz?L5Ob4+tGc!ZJFRE2r8IGA_`UXPgsx6A>v42`J z;CMMYMAtK-6I$veq7^8i!+1SX&p0JWBga0g1=#2)>w&22mI8H}10Y%!Wi^J{so5#0yLeZL9vx8 z&_#gE#Ll!pEN8GKJ!WQ1AijQE*PNnot7QYIuZyrV-fG9!ZK$tot3@v%Qd{VNIK zOtz!4jxF)fDZw7Q3&AMdq`N!L?MKrg|A@*ace_z?dKr^|n0&b294!Y_ZV!r;xUT5m zWE>V1XqskM=k~@>JycM@Lr#)mQ6s;~BxF+O_4&Gr@587JRR6>xjU-sT5MTG8>DXa` zxLwEYwaj{muX|-@Y8@!BrgI=6NJ=)bV8ft874K`>Rkq@;I9v-}=h*fSL4>buUYFQ@ zYmBdLw-n(@g0F2}Ka8VsystHORx22*&exaIZoP#(bP0m_+Iz$xMXngs*B`n+Td&(E zQNC8+XLH8V7TJ;;1Ol-41!Pj^Z|7E!ME#YZ5;oF2c_R;M8 z?XXp&Kjcdm6+Ed4PtwN<$;iE)EVFWvg4czanFi(ct=kNzEY#QP2ryn>U^`Q0q^})b zV^_xe+VNipn(@9y_Gw#8@b#m1Cr-6jov%yDnHlpnw~cTlLXi1daxqKV>@=$A1LR(UT-!w_sF=m$;6Q z4!)F9GU-;?S;M6zSJ2tX@q?}5WXlIRMO6|OBiC>Y;Wj2KYFH|64R;eh6HCRd;r4d7 z08K0vvxdX5&(p8M0+C9^>y%ReUzFZT^~90nQ;8ys*M&t8=l|f8h5A~hjJB{w7!@YvI_wT=Fw{V<|AISQxH&U7w9F|eBAxap#d2@NMHWd^6vC ze4@rF{P^jw!?Bve)wAAFrk!*7e!sr528#~^+{YCu#vI>6y!u{J3$+~bBq~#M+52iyos2BTn{k= H_ z95FDN%X3{&4&hFk{3WHMa0;uSG~wT{gDOwt@;7w-MSz8^JGdYh#l1QVm;G@Wet~arU(Up3 zUt9(_fLVAj6PNvQxzNMwj**GWzPPMzI;-EY#^n`+SzXs-UQHVu)k1q2p0e^>9u4WA zd?j=@$cE8h#B=$1{(?!5iWPX|F))|qr`I3l6bcXgu`6GKS@-(DTy6*^-@_`XHS33P zr+afY)w1+3*w=9>2N~VDksay`GWFl*WH=Y{;TxHDW>M zUrWdi#mZH)QTo#W-?h$n%bL<=1&{R0NC@ivr4i3G-ytb6A`C>V;12Gh9hlz)(Ox6Q z|3m+1h2blPzu9x}ybMAQV5A;o;J9cW;uKclZg{pMO_NNw;PzGc*9>>_05E64VihWw zD4UEB1_D`fx9j@tbj=yTLrY!^8HHWQ6;l1TmAef186Coha5-MYILOU)>;(hX!(10H z4<(?H9-iRj24CQr!u{;ccJjD*-_^#zO8P-9`^18=461H$tkAezw#2$*QK^eF#o$)KgRFodg!e#%BG9AKg#u}Gz zTrA$a`}@XnDm-exPM8Tim-j9$_6r<_+oEg7b6Ks!3GRwXj|EV^#>)@R9#11`s=Hvj0bR1MOD`9aNPhj1GY4-m&*^xfUj*rU^+@+p1a9o<^lkCB{9E{75 zYvU{jg>acB*+azT2fJR9?c*{{vImdL@Hv2=8)00wlkDZ>^5*5`@>-I;hBaI_{103m Vp)@h+I&=U4002ovPDHLkV1j}yuuK2| diff --git a/docs/html/img55.png b/docs/html/img55.png index 0b94ce1bb965ee459976ac7201259b944a088dd9..4c3c8957b00d888aa38b487e4fd683ae8a8b751f 100644 GIT binary patch literal 198 zcmeAS@N?(olHy`uVBq!ia0vp^{2a!NKH)*2?=p_b~Z9HQdCqF5D-XuslE%Sfw3gWFPOpM*^M+H z$HmjdF@$4ga)JU|!Mhh$7Yij$JP3PWbzlR-iGtJz*$Em9MnV!i%m;Yb+MH&5GBr5H st#MX|D|G|6gQP?9fdh;Fvw0XZeAnlh`ulXV4A49VPgg&ebxsLQ09Z>#g8%>k literal 192 zcmeAS@N?(olHy`uVBq!ia0vp^0zk~i!py+HxR`CDK9Hjl;1lBd|NsA)GiR2UmxqRi zzI*r1*w}d0s#R%eX+U`w7ni$t@9y5c`vHgkJs_X4B*-tA!Qt5rkffKVi(?4K%;bcG zgd_&WbCEnJ8br@!F(jFZSgvE`V&%!n;o}TQl~HKobmeq@>Z8DLsfSM|m!~H|aT&vk nIqpnT7IH4!F?H6~MiGWz=Q+;qIsK{_XexuJtDnm{r-UW|DilA8 diff --git a/docs/html/img56.png b/docs/html/img56.png index 38055651c907a81af1dd2df94e83cb4d7434cd85..305f7e0a3adfbd615944d41c5ba4fbba24b65b46 100644 GIT binary patch delta 200 zcmaFLc%5;Acs)N0GXn#|hxwLDK*}J%C&cyt|NlVdyLa#I-o1O~%$eQ0cduHtYUa$D zWo2a@9UZBusUaaD&d$z8Mn;N?iUI-xNiWrR0W~m|1o;IsI6S+N2IPc#x;Tb#%uG&D zklOIQq{PH=#%BqMEYSmNVtIJ>2p?GUo`>fSy919{q9YrdoI&?zMrP*wOak4~9#U!z z5r0^Dc=jgn_ObEk#3vj(YS|zm_T6fiLl^@?>287U2mP^&ics(BrGXn#o&yib#3=9mq0X`wF|NsA=Idf)td3k7P=(~6CjE#-YoH-*X zD7b3Xs8P+e;2AjRPFn`eKJrmP## ON(N6?KbLh*2~7YbF-Elj diff --git a/docs/html/img57.png b/docs/html/img57.png index bbdf4b88347d61afdcb9aacff51854eb80f9813f..2491b4cabd478a653699383f813be86cbd45cbe2 100644 GIT binary patch delta 399 zcmV;A0dW4M1Dpep7k>`~0{{R3ymd6%0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*I8c9S! zR49>SU>InS0w$R^8X$x+PE251-GHj>8Ur7Q@@$)w!vF^62_QzO4?_o=#U<7UtRV*& zgcw*Zu{~g5;OGE?R-kMl&>RPlvVabTW31c-YzJ658dxtd@D*?_Kr(F&Pz!|h8E6K- z0Y?Lba8%$fKz~y90;Y`R0qX?=KL&ndhFlh&1cx{VeiH@;?lVAe6eueSbQM?`>j91h z1+y4pIT^OAF)9@JFvPJVnYNvQ2@)PmM=N(KY-g}ZW$2v16RE(JR-1;T%r~_H%3@(K tVlZG}QUEd-fSz(D%PDHLkV1h30mBs)7 delta 408 zcmV;J0cZZ41Em9y7k>@}0{{R404~?*0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*IBS}O- zR49>^Q87!zFc^JJORptY6Mw9wi= diff --git a/docs/html/img58.png b/docs/html/img58.png index 2cb46436b5914a26d927f938194313d45c650527..4faf223b25e38691272be477eb70fa86bfee15a2 100644 GIT binary patch delta 694 zcmV;n0!jV22Ehf87k?iF0{{R3o0faT0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*JKS@ME zR7i>Kls|9NKp4g!**?d{ZiDy)1|d)dLKbD{&>=7}l*$r+D}O;`sZba|Iw}Ytgk-6t zNu^fmLJ<{1hVlVmAPfv<0fr7C;?GDHz5qptk@xPB)^^-%h$W94zqxzg-y@&>-T_1X zL(Phty<1|idYJywH%r^Ig#b7VJxY~oTqXLYzXPuBjC$BKM#Amc31DUus3tk~JeG+( z-2}ewjC$C5vVY_;{g#0vDb9*jB1iSqsE0L^lPzWGdRfa>zU7zHNMWZdTZQ`~G+;el zGh$_Fg&9jq*e@zIdI1l(wzvkpRuPQ07xyBpU%bHutuUi)cFs@9fYT!I)xL~Y^(dBS67PP`ndJd=mA~+H246>xMIu+u#`KfK}Q|L&5qED9<30h%g6i=9~ zk_c{SHO%C~-)@q+3#WuZ&*7KBe$Hz@2$$%79k&c>!{WH06*h%(!I=+b2#@iBpQpiE ztJ84r{C~nLvL6%7WgE>y)P`4VK`U&}+@m?`nGAaKwl8|+()Su%KjFw${%}e-Tz?-} zPZm*~39)p63uf{zmR6|^C$C9bVW;4uqyjAf8_MNqUjuGH2Mz!SY2Q)3rWnnK0YWuT z(pl`f*b3c!S4CF4Y{)d7#omn3%eCd{kU2Jl>@VD7BTe^V?5wyiNIr*I7;Gu%JZz|; chWd~C3)pd~AG4`HlK=n!07*qoM6N<$f)DsUQvd(} delta 814 zcmV+}1JV4!1-J%~7k?lG0{{R48NL200000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*Jwn;=m zR7i>KRXu1FK@|RWZ~yn!InERk0ylRcM2_U{Y73X3A}Y9*^?!1WV3k%uSQRvaA%~_A z8?Ug@#wFD?!K=j1MKpztTSzK}HBpI#aL(@D?d@idfQ?AV2Q%-@oA=(ld2jYDkb;(Q zbSxwu4nij;0vr8F`yA|j5>ocZi?7(k`wrX#&-h!YBSwk|bt$07ycNwJgu3gxq4b8Y zQ_O*ngA(jqynp`|9v>024l@?iGsVDSNDMaoFQ&?iyw0v5gRj+s@P>Cxl=|m2k#I6u z+<+)DeS@IqHwj;43dPusjzH6AxMPMQ`I~|4Ev^$KDc=eWi<%sIc3*&vl7_>KfF*eZ zGq)Q(cfT3V1(u_T0qHWU1R|V}L|H0D5-#CVZ*wS*iGOrKaV@G0Gs~*UW*Hy#f>M-K z-m;uuoaubEb$ufpln$f7^U6&h)UtGRn!X)M<&qgxt!DTU*h9@CsG*3w)+ayi z^`t3$_O0=4-SGJCaFID6f>juCr_9i2(igh>6l+m8IKuxAqwYygvXa>2W)FHUqav_| zdC{C`e196aH(ov;(&@C$bv9U+)$EL=3!^_dpju{Ch@M#c_cvu5LUo5?p|XWHu}hNm z;G!6Sn_YPXRJUxSGJslH7OD>%VI6}eDG$oP!igubS&^#U4-YYqg2UQ=EBgD4M%pE7 zs6h+Ya1z9oTYF4*bsn`3o5M7o4sor!yRDqY&cO9NNYV%BOmHshXc5Ae=z?@X^sjTr}3=4ovX98JYYYHKC6 z!|s7IUi&-6%FdL~SPI&=%g(uFyeg3i?C@woE7dkmn4r<=)2!|ej0Ab&rxNb0!&j0`b07*qoM6N<$f+lc)>Hq)$ diff --git a/docs/html/img59.png b/docs/html/img59.png index 0896a6f55ed36a52122c64b4067d251836e9bf66..56ad2960e66ec5f5a6d24884ad8c6db1e5ca6843 100644 GIT binary patch delta 202 zcmV;*05$)c0^R|T9De|jof+@|001gbOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqj1UA)%jEZ~y=R0d!JMQvg8b*k%9#0Afi*K~yM_V_+Bs)B+n& zcudo`H)&dj(PKFb_4nUqZOdUjkh2biQ!+tFk1Ogaf0z*s!sKPLT1I!@G2W}f! zAe*a!g8|t}h`{XhrIWzi1yEs#0J8!Mglhm5h6`W;09;iVz=s;4cK`qY07*qoM6N<$ Ef|RCBCIA2c delta 264 zcmV+j0r&pi0hHh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCQk!42! diff --git a/docs/html/img6.png b/docs/html/img6.png index d96fe9634d1b3d33ed767f91529123342654fdca..054a6f2c12a5ed4cf0a0f5224df68478d50e5e43 100644 GIT binary patch literal 328 zcmV-O0k{5%P)BGeIYT(6%B7j$X3ibfW6y5Ur_Kcb@P_Nz9@6}r zLzboUTprtm<#O)G%9>n%^ix((OVRQ_Sv76nMt7}9o6~*D<-qI5Q+>x29Y(&Q&gnz_ a2kH(e*x#xCC3edI0000F1DloxD{&|v-l&xQpYJ8qaZoyk+P zGssx1gf2ujL=h`011uDYtm!$SsBNY>0C5A-Pw-_ugrIF*uqkZ%o9AD{P`Db2fJG6> z?WDz!T7W^7icoc-+xkP=-o81|7g008xG%Od!ckd^p|$by#WZJriB^+-l*BCx@jL>q zfK~>rCpF4q#!i=07=bs7Je{gJzL?|x#B{G6N}(})!bgNVE3<*Rwx4CS;@x*Ti0cLD z-ZgE44vNkU1`B!LA8+DbUFmvQBHv10cb<88Ih>Vv&S|crWc+S3%=84mGe6Vy4%`5s WMg>Z^TKP%<0000?V^XrMjdbVZ{eUd>ET<3~j~u5RE9lSZKkbQHWmw-70OGw}4a;L`w`>p@JC2 zfG@otb7$_(PNtKcrPGHV*x}}!dw%!)@66520n*v=l=*;Sd4q}6C}x8V{%f}UO);wY zG3_TY((P7``f-G_1v?~0FJAQq`x4Zcz_bSch0KxTVPE9Z>k`OVKkW_F>s4=LBuGnO z?Z`M41xg~LX;p5@bj-B10oN*HAqv!{41BYOw6H0k4V%y=&xd4;%uTsa>H{_gUzqY1 zyfW+p<^CFzv9Ed($dT##Mf(F+0&aclIU7e#xY*h^!|Bvmnq=ev*zX8~g= zWNfgzYbZ{1mzrg0ix@{?C}*Q$7I>A~5|)5@EK?cEA|4?w8rflu%D~IG-&U3}gEw)A z)2XpE$>>5AtIMJT&H|=V$T)_aiM+MJ4#{ZXKuP<7JY#36D}g- zaGl988YsG4240hS22C`s^*w?7r6o?M#?nGE98U&krIT@tUUpi=$6I9VD(Nt$=>xPe zkfHp8%k&Nv$PU(!r>iTcU5S_fi{A~PhBKT_=diR@WN=oxhpNj~YIqFYeIXeOWG4-q z{1Y6cH{F+^_26HdO8Xo8O?Jd#DBpXhgcbZNKN}CCj%}Pyb6J|S;j#?QN_WI_R|tCh zD$qH;XJpD6h|;f2HKH@NEhiP)p>pC+yW42g%N=bXD(= zis_<|-Sl$K_dn^6cISB1+#~2gnr0!&7)xoavGN2K@g9t_;A5l~Gb=DXCf1>kktQ3s zk!V^$EUhN1VQ);VL!X9i+34-3B()BGsNb`Dc6V6%Cia2UghJC_ceIHWEg$r=ZtTQh z{Z;X56XA|Fv9n^ZKj_M%%?UdMK6nS!<#0AlY)h55ognar@7X4YvuR@6mk|VtW=2gc zJzW*b(>{C^>X|%sEKt1j|^T0ev@On%!@<@^|G$yQ8~u&yk5u0lHJUx ziFE|eVSV&fIkx`!k%ukjWgYu_W*E=wb$qPmX4S;XGTsG#mt*>z@izCeyHRLJF^1>$ zIV6rX)%(y1c-Ug;u4rPtNj}1aDW!%I8J^W^3GDVLs3&99kZhf7 zVq+1piS<<@88or6h}c9o(b{p=!6vqCBOmIw07Gx}vKyr>d;kCd07*qoM6N<$f;nq* A!2kdN literal 1916 zcmV-?2ZQ*DP)MpV0000mP)t-s|NsA) znVENYcU4tY?(Xh0Gc(N0%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001 zbW%=J06^y0W&i*N`bk7VR9J=OS>0>sY8z6&t}PeQ>O(v3{)|RPn{N_)zQDG>BGW$>KlYs4qgXtb!sI>@;8~L|xCh zcV_l$c6SmL5f7W0JLmJBd(J)g%mf$+9{oxv(+wLa!?Omnc8M8AfFe*40gM?Gpb_%k zP+U+XQpKhc!6677*}bnf|7LqkGcGmSVFhA@-<{ioIYeD_R0g z!04SxfM#UH1s=smS?NxZJqr!e@{q?DdDtAsjr}V;k!D`e>gq``LZg4aC6=)6p+B!o zIl?gvN+vm`#M7oqCnV&-ra_slD?iL$t!{X)wmIkdUY;yLF9%+L0xj=)u4K3+2Qc-r zpl9n7?W+uN?bLM+N}VN&FR)-HjbJLJD(+LF_iUaLd0bx zD(9Hlcy=?EunV5Turu78fB#otNkds3gv!$ z(DjrUfPVo7$Gk6%Hm_5l=}g4WUa`1cW-i5}M%$HA*+a&bG=me^^o<;li^Yi#87wG< zqCrCsiXD_P4&7=TGgD~m;=EsB{8^D{;b>raQ|JAI2drRT&?FYWmr9Jwbz&`Rv(`%H zSBLQAt(aoL(`<)eVF9NLtNJb>_p7m?Jta*0;DLA-4}??|Zzzl|=DAdQoK#$K#qBAY zbqpXNI-zW&&5S`d+FN5-#U61UHWp=RkT#qJ*cQi#_AMnC0s(}l7+l)W)v9o5gKP1$ zi&>@!WQW@bpgkM=5ty8@a=3>r@h~j(M0hiJQ1&c(yvaFtOR{JU_oJ>;`B94f1zr+Y zN^?5YswBVLkr?u$AsSU4dOl?CDjTRZkRNVi1aPV+Wq3C#U9-WUi+-FvfVVr7>Zxt~ z_o3ReKV+4w^Tm#NHu|JwmAbzN8M9Txd%IE$+JjXLAVeT~p1atjbbw=S?)lJ$d6iod z)*6lU8u&(gB+wUC>DKSZ>-MxTNoPq!>h{;PRpW|!x}oxhab@gDD?IF5PHEj(W;G4& z8LZfkvgupl#&$R(8T+`Bq4OZ{zVn+-yB5nSd!_I&&&>Ng_nYCF;~#Sl2BxsQYYu^WBC-(>-#KG0t~bV1Db@kkd(igJy+rKGW#n2* zjQeftUi^e3pr6&_1wCj@{Jh;~)C&=cI8Mm#5GZ(v3WKrF?$B3sS>h61if?^OPZR3v z!HM2CS!qmJ9rsY;a=3-J)V3D{@5$bv-wU_Y?D4{Um|F$%;v?+!RVkUcx-%5Y3)X7j z4}OxM#0Gdlx{M}`Ms!ZYKsz}LY-=5!#aGKdcE;aG&Mwh#-{k=Lqja%WRxo*nIJCRh z_dEJ>fceS};+mn1dZh4+0Pc(gms(TrQ=ZNuGd&GlS8=ei;z=uC$8 zp4nY^6zol5S&!bfXuaLKR6EIA@M0#F-C;1Yjq2AHTAzv$$M76p1N|=EP@KB*CIrosPIxjBxqQity19AHn-911)ZlJ?z>oK)JB9Nj>%~+ zByy1CvfR`)J^4=lX{&{a56-j$DaCrc@Is5LtgQpGUtZ8cEHgaa^<{5W9>_BrN`+Eu zQ7lYg8RzvLFV1l+8kBODjZ%hQ#CC{Cvjq&E8%M)johhknYrL_q2cg)EiE8 zhtOsR5xB`n0qysTgm1hF@cS@gZ3r#tA2t!>fq>wIs!IN2)!)qwy2 zKndw!iv|E>@X}?zMowCB9mrWH-M}s=jNR($s`NNFHzyPdIUG)7W8;%2Pbd^hWMpJw zVq$P`Fb0D;di1ENsi~%>rn0hfz?AL_>3~cG+Q|)IBN~z3y1pA}djxYicb3)?y2E}; zSIE#)9@5p%>>(Xl^*qtJqccO_E~(uysL@0(v)Ii)K3Q223e|*ptsa^gF1Z2<$_}ifv8}@UB@(V2y^_KJ2^HhFQlh3ziMBFt=wD@qnfacRb!_~hx zR5qW-LKOe_PUG#K@F9Sz?k%ye?3obed3zSkHc|0Kml`i_ihmW=h0>m&EjEoLYPbq@ z)*J1-?iVyyY+13ruHa=ZpIpxaR28^}$i=_vaWf1k{539kE2dpuYI9dUkrWqk>fP0l zYdw|1CgAt0&={2wM(=KV-#N;?UDQ!b$?JP9HpL6mCoP_BnUxXIhGoM0hf+w~76o{! z4i(#Jq3miRPVxeUZQ*(N1 zUE%uEw(TYQC=m)&4Jc_XLUv>ej1Hpt(zy&X)S2&2`W-b5Ar@du!dimmXprblA4A9B z8O%9J}~HmaYkP6^2JguWZr5XO%69JOofnr{w+WG*zt zj(Ev~K}H=wZ(HIQ_$_KrO$K~Pi_iss@_dv`p~qv%dK;?2ZkzG`MSD3+6q1}k$pkAv zwEfla$C$W{;YwXW&jWo2)U@gV8q07(uIyby);33KTufj<%F9X^~W2TM69#4zHsI=zn;YUnE&i{1_&M5&)&hH&#_0T(Lp>6|etwa^3WAS;=V}Q2A zzt<(!l!Gct&D^O==cPssW}9bI3jpbtK72_%HBM#Q!#nSY135h$u^;7I#xK?s%fccp zKdWp4U#Abg+_franAKe2@hXY+MxX0_@P%K`LbOI&T9+~Pohnqqp%ZC%5AUWJ_c60_ zm`pD{?Lf=IJH+GrU4B~)v+_L3e!d90&h68ywYoICpkDHyT0~ReTmJLUid$-&=RLuf z|JdkTypRlDtb>lfNsFgAD!my>DT-^00e0;_8T%j{(%r1dQ3Eqk$NqY$h3clmU-D*u z>mt^^Z!M-i8E9Hy`1c-*UU$Tq{n-CNzbKDFgiHttX1kmjB~g1ZGlyC{2C};e!qAmF zCT61ddp7K^M&_j9eIHg={nlfZ{^F|iZOu>dMyNqJG8Q>lEOcgIjq_s=?{~4z()Mw zPjAi<`%GFN2kK$(}eZ@-i}>HUko#Z4o7yEw;!*u|RSDY6Q+Ni#Pwk*9!f)x8jj3 z)o{}4)5RnLx=+X?$n4?J&m7Wemm+6vt*kVT8p{EymD|e={8KWpBn9j0s<9c=v8#g) zFOalg9#A057NJR)za!5V9O&!TJZ5C%xDa3ePkwgKDPLFu1^JqDe^am|%=qNx{tak( z^EOxcbe{IIzMhmZI=Qc#tQQ$-s(%Z`fAfl&EgP2~Fs#lD8?L$^dNdn%!Kd_gW049& zLx^|O4LEJU!jKWBa`L}fofWjgt_@QW1t~Z4cLX+YWbcwW-C%}?8dOS2Sud>acu(B< zAE!8fB9qFg#hOUTFKRYPm_^Nnb?&^8FxL-_))0TX#O@%_Wz+9m{9(QvA~H|l!!|{U zx)l5@7FOoo521}umlN@!9?7;^84eMxizbP?6(+8&=!Ssq&yxnuyK_k9yS+5bxy=Dm>IvwjG#-t3sgL{0DcIRQ{qXXN!t#FI5!h~s! z5%s7i-}8Ms5I}##pH0g$go^1V&lTs>dV(9!0rJ=DIQx-(nwIeRkvfizSZ#f($BMJP zV05>rb71ME9DQHmE-gr$VLB{rhgNsw&hnoRGRKASWo<0coXu$S?{#ys&dh)?ZG`lL O13=n2*_Olo;{E}O<(Jd| literal 3748 zcmb7{XH*l+wuVDhI>ZJdh5!+P1W6DCA`y@xML=pONpuG7~!=brmx=Er_#=G}YkXV#jDFgDcT;XKa?004M&Z)utU z08H59p?s3%cs|L$nshA48ylEu9UUE|rl$J&`I(!WFD)%0kw|%Yc{-ggARtgsP!Jv- z?&RcjyjD|Fb98i6OiZl0y1Ew;7JnRK@-Zd9{aNU(Hf$G!3{^uaBS$dlF;1+sI+!E^K3JG(^E#kAy2(>JhJMLx~h z4boM;Fz2V(?~1l=6l-b};YR;l_oIV*2_-WR=dJ#Sy>hidUT!N_TNUdzx%%_{7t|@hY3#wu$VV}YM;{rY z>|c~K*7S@WpTv8a!6H}~b2C+z5{UB;jStRCo>9Gb5&x{2Gmc^H(K-AhRI3cUh#ttj z>L_tzY1W9axI$U4y5s__cyO`SZpqs%JbcFG1~E2kuKO`c0kz0;=iE{MA(ihr3C>i( z`pBT8(akARKn5?Xr;vI1!s0g}`|1?RjCM%Fi(C6|b`?Hr_1IQ7ASBc1S2m)&GViA? zv^HjWbn+im+8ksL&Fsgd3Q0)~rl%f$n7;Xy^z|jmz`Md?qx!9)Hay}>$L3bv=-p;u zo#)ZV`sNMn$T-DAq}N#{wDwN%gm-Pa^Di~veAGuPCg@WOC3tT6)j1wodN1 zSJHd(Bvo+T<_BJ9ANs?zMuL={rthlKK9Poh&A@6h!zOKu?ija@$P+p0gd=>Vyn2DO zJ*WHCnLW_pD(uRL8Z!%D$8Y=0p?I9A)_QW%v}g6rgRti(%WEi;4+FYXxJ!wsK42lx zhyFDN+Dk>y?6As;zri~Cr7=bde?-CS_WE)b%mQ3lK$V2xi2lRe8>!-Y&3S$aqKb)D zhrYBCi)rTq%6WKf(_UELN2y72)Zs=4SE!ui@TON}%4Be}7oFq!?suQ&cHzk>?3{3Y zBLdbIP*arhj%Z1vv)fBD=e&FySb$65MtLT3kzbWIdRg_&LJ~Wb1i(#+7 z7-Ls%zcq*p0@P1$X9uB5XO{DC@6lkv4uuVg7ode#st>kh9nOSz=$E-X*34>5++hxM z44zCYOEK40S*zR5ejP4Jh$_VP5HQP1USQ z`}Hr$WIpLXZ+RnOSY$kH9d1hSq9+KR-b@$$u z=|(A=o-KFjuuTeRz94pYW1>u2wILa~(m%T7jeiTtyzi#NkW`(Oa^gQ#A=sl{$LZ4j z{Ss^nn_eAfXBlU)i@q6n%dJasatswN6H5$<%O}tkoZ(HCHNjJ_4en=kZOgP4?O;rr zxpl|i@{U@4c^yTab}%xt09raPT77-rk|7mkRpD6Nao6F{wOjm=XI-pP9zz=jud<}i zSWXMS4;l+~Fz#@B^NCM7{Zk5Q&|YNqSpj#F7dI3ST4V#^3Qk8?@MK)ln~vF$I1 zj_{U=B{||(lqz#r@;F_)(~grhu%Z`0yl-36<+>tdJAr5?ZBUCob%6Z@56MnIlyI+J z-BmI5qL>q=d0p(m%x513f#t7YcboY?UX6UZzlgs`^bd?1zCMtZJ{Ejxz-PHugl$jEIAJub1;WrQ}zyUq1l)4dF;Sesv`rJgHmq0TKDCZlaOo zx*w*KZGQQ4Dl}rj>eDH`KOo_G9wt%`S}VE15YoIL~_BzI>mRqY#-!!;{w1U><2Tzc!ZvM588HOOPl!*)!rp;ny# ze2!m;&r7cs3H z_F;k#?+6M+TAD09JNrN>T~QZ9o%U#VAb-2Hexkje`v&xxZ+ z-?3pA(HsmIId{+Zh#EAkF@XD*$4fi9T-AuR4mYQwFKg(PmFCc-IWVrB#2m{|?ZirjlK1V6Nt@Hkhbo*+MYAes z4CV~lWH6*oi%Tf^WznqK&tLA~pS+5z59C!AzQ)Kpf05@zv3ZqCpqm>0QtUg<)9mcl z&6?6L?0MB5$!CmyZrs?(?c{j?fu7igNgfe?6?TCrU&^3CPlv=9Sv5vvk!e{58kK+F zzA+KEmy}gZooPc$0U#xGS>8?n-b6Rn9&&T{Kh@3f*ncE|Q1l7e6iWHXi2Cjqo~>$I zCnPm1W{p6Du#0A|u*y=S!3GJV`XkyN;WXe*O3=)&@Q;U+%xSh@l zuX?WLIcmibf>mU^N~r%OmL~C64DdFF$nfIrN>a^&J0dj}xSH-3di5Q^3|Ce-Dm#C8i3enCe`2ok>G4FwMeri#gdx-tL8ce!eZ2%D@5W{vA7);^H^A z`?d>m=F;GuJjqvTj4%^E!<04#3fJ@vIcD@jVUR0>--7tP<4lv?#4DE>+3M77jn5T% z_9)BF9*9GY{iE9pLD^_;xKD9}>R_AG94-VjH%CPtMT_@W6qnHIS#eD%A|)M;hU}zf=1&VD5ktL>}by#JdZbGHJi59b`j{w z>&s@dDfqB0arEe!!npqS3}rXisA&8hs7+#~5@RqZX-U9xw7$Vwg?eJG2pC%{0z~k? z3+XQ%HqTxSy92o&+4{t*Iq|i$kT)Z@PtsJj(5Lh;j|WLr6IbDe5${r7hNcT(^6gh-4JvZo7`1R191 zdJCBJV{J!xq6XNSc=OdwdN;vi-8wG8XwLLAm;}MNhBX(tBirn?EPu`&;%*TB{g$s) z*CB$JZ*eoHP^mdD_s~2$YTd=v782$P3;Noev|#!Ev{uk8BAyw&KIR zOJs%$+SHJQg~Jm?Om@_^*#09nd)}hUQ>J3V9lHMxJvaQaiz+wnJOvt6GTj|-n0$0$ zB^-E6Xh5Cc<{?cER?bFTZXny54;-8CJY6o>q}l8;{t7f(c)`;o77?fS7vn&uzQYV(>A{XC7eb^f(OE!w4a8?k#EGQI>o@= zf06%7u{~*h7A~~%wTE7X{_%ikC>DlfVoD!fmO%qy8-pN-N~Km-R)QcH8XB6MoQ%Wa z?Ck7NC=?Qjl#!7U78b@XD86AQaNM!6u!ZT*4Y8~8;7rg4cHsrf&xir1?1ev0xSXFS zA^M!ppio3pgC5xrDG%Akt#d)dFqx{Nn#x&>NfDLdd6RbvA!CR>k}S(7mT-ix1Y?c% zt>!6EN-V|LF*$NdP!+FRNbtr0pq{k8xe`i?wzj}BTfhmw&GGZ=Jpt(^-{_45ZHt%t zlj-);BduD4cdn#%e^9r08Pr{H+xUFz23e;*s3wqq=&AZSO{14Vl}-zni0x(0hbT>` zu!3Gn)BYn59Z@iQrE_`2ps_9MC7ByP*E0Q!r|lkB>st>3!Q~+3MV5IIpy}kip0WJV zux*rNU&rZ;lN`~TLFW5>(k=U_dTw73@4DZdp9UFI<05u(?3jKzx2ka%st5j zi8(tVH01_2$6U`teRRhy)Ogq9sY~i1(yIw)b1NJ8+It1K+`VxW7?H+r#fPPe)yKb0 zNo#p4PShG!#l~|TwvOZXdjL;4D<~j}&494M1X%H;XlC8Wdd>@f zrUDjOvG_cy30)~XXyC}9M0t}m;1c_hk< zFsAco+5ot+5{PbQ0_K8`kSgl(I0wL#UJd2sID*Q`>z;X6hq8Ioo42^|8~}>nO@n*6 zFhpC|Xwcz3nWDPq6~P#7WUO}Gs3r4?CehM{XXMloi%usSW+MyKpZPb%a>s!3>)e1G zXvl@J{#>3&3G889=kV|$__KT}FE>pMePWs>N8Ka6;seBv{l3uHBeYlqkGq{W9~PyS zAMFW6yH^Q<{4wwmk8xGW^`6f!??93s?5ky2Ez@FbceXbiGL$!1)ZAe)BT(1&ED0I) zUWw#o%6^2U1a8x;0-`VRs&fNFeF)4|#WuWJLM=Ikjm{MICXWtYR|p&L>nHB)n=Sr4 zp@#ec-V>hsbrdO{k#kHMHx;e}wc5bKOG08`?QV{dn9STykmguedAkW9&GSehe0FP{(U;_;aoHN@{x@!2Ycc1-9_ui);-Kk*NIo3A zw+!qCRxL#s>FE#L@_*`fSGQ0H&dzzg;-{Ec(!**=y&A1e{&%8jwaT{C(A{WDz-bFp zz}a9L4zFaB%k&>|ofZm~2-p`3;5)MEfAtUeJ8A5eEbtx4BySm zk-^;7+Ae%xz!1P~CRhWE9Clj@)#yv04M=M6q;EZ2M#gH6pRh_ArZn_^T$+vCG>qA0 zB%A9YXZ1B#2Bdyj7q4VYyzYOUifptzeR@sYN4Jzb5L$$wmd|<+jGGOee5dr2#G$wA6a`vb^#Jw?wtqh7a??1yt}!m7 z!R+bT;Ah^k;yod#+_kXMu5F!#Qsx*7IiAX^^#n%#l8BU5Gce5xe6sxO-u}1u_&5AW`l#~c zdUd~z-e=0+94q---~5cxyLwA~*CNVJu>v!Sgm%Mvdl0i{^5D!hr&swN^c1xTmp1S%l#G=8jpAn5|RgGQkqZK3&jN)c)aUSMC;s$WNpo zenMF}@4WX89>!*?my1gqzE=Yg>|vk)-1O}#hgF!B=g*)e+jo8`jzHPP9l01YcX16M zBIf5?>y#$6rs~MKt5n_D=41B%ceJtP_1m&U$0!=(-)>~{+cMNKT5aN=iW-$m_wzeS z2>Iw7Uq_bFP|PWYHNt%!z-huH7QWd0OILT_U4^gTE0kk)nN3LbCpt3_#94xoP*4Z{ zgr(ZoulMm{AW)d=sCPs5q^PW+1r}-&B+`t7;1gedf_k%2J&e0clx(! z!~RRBc_fn-RKBVW_{3T5g&!(yPh6TL;4`HzYkjq@;lIL86?;17{SN=#_4hVGtX!g+ z+{u|wmOY_glAyoN2%*IS3RTe)Ng6htDZ(-obKznA&62uyOfY}PSxN6GmY_{eUw3D^ z^vM~9o0Ld+!6E9tqTRAf;;>tN{9v)4D~p5Z0m!bdInvm_515Ie1-kZ%+x`Cnboq1S literal 3122 zcmV-249)Y2P)+i5o8d@ZN-b8O7XC| zt;}IgvWHer3nKd`wBtb+_Ry>!AR@Hj!HXE6AQH$H>muvGLhXzzj*e{OLA;2~x{8No zwX&)*zTSJ8kx`k|nZ55pXGgtw@q53_jE@%)Sy@7evFHi0FZyCGvn)Lmr6O%o*@Rpj zOd48yC93Lizlgo8)34M@YpI1+i-Xp*-y}V_R?GBBP(o#Qs!qQqQz}<=4*fpXgkObN z5c+6*sY?7hSK4Q@$P87@)?2#0P%;o=;(R<={yUp12U!cA%cx7?@5(g1@1z{%iBVWN_I==N{5{PQpEs%(Lk5e+Y7d!8n*-XBD9BI}mVr@0 zX0z7P&sVA-(}i^G6nQ(#nW#`vXk85(uZ}mbd_BzT7x;wV*n6Y6Y zc5Fa2-OvF{grOWd#SGs;)(U2U@Bx`R7Trr3DnN@tTUs&i zLBO-*EUQ^pV$wQm7$1dYy*V}*o3uZ0fqUto`q*?}f8p1pJ=T7QiS(Mb$kxfSL}5#l z;-dvDV7ol??Tkky+zdQ;g!mShkjrc>{Ve1PT6q=2C40@gD@Dnje-0MKBIEX6!4_E; z_H3|pTCeH*E?Wq>@M{ujJ*bB5hq{f8fF*6G2)8UUU22gw&m&;DbuiyrB>ednjMi(M zH@IO?^%+c4G7+n}+(K-Fx|L^o>!9cJzn;j8EUb^S!#Fz}nUs~@Y=4#d+S9r2^vPA? z>Q{5s&y3^oR-Soux=QU56U$CY;VLweDNC0c9Luc#Uk(8>OqonwlGzyRa`9scD%0~q zXEHQHM?g#SPZ~oc+y?%P8J0;n!3ol*LgOm)U*$Ntv3ttka#=GcQ$74ak&kt*HPLT$ zs)jIhke}9JGRI z7a8>ScqWkD;iSHB@^DI?mvSGfY$T=cJV~jytmb>N2?ZpM(bv; zK4_@T5_+NC1nZ7N7uM?n3WfFhXcn$RK)}K=${ibfg|lg-o3L30SEPKl*Qwjc(3^tZ zMD(<&$z4@w9L}DW4WU&*rd_mAu@|IMHKb-}_3+o{O+gFwOheFwGzX2WEFhUKGP1IO zdKPYzLCjLtLt=(qiJU%%lMLNnX#7i3G1Da6i?7?nUI7RvOIXK;lPrPko7733cnew$ z5AxKO(S0Aq8<@?xm*2fgjDDL#k6xXuQh%7`X5Tr>Gauw;J@lJSubJn_fB5md$cJ;) z?&1m2Ovbrt&y3f*J9+YNhbZa2JkfhQPwgM)scDXQXw83bGIP!cA3>238J3$|Qi%=K zp&1tL<1VUpbV#=o6e$cJ=s-QR#L5?Tl98Dk=4>+)uQNW{G+8$aM}?{<&d7|+$c(%W zGP1*tW?G{tvy!=LSzV+5lN$D8_v z0@;LLAjP##scBQlCgSc6a!FxEW@JVNhIT)}_H~NRboLXBnJ)E)^v{+kO`n)pC66hX zk5Jp{SsN~3K@C|m!)I-H+LVc#wIOCaYhz?aX5_k&oqomkNQIe*8Nseaj7v5HP;IDR_@hP4A$U0ItY$ojG(K zOJU>&k<|--ZVLIAg`LSd$nROYqihMOsJYovpfL2?xJoQJTGbglqKQ=DIpANxq8@y-sQa?~_9d9pRvgyb-#KFBl z_1a`-8alW=nw)`>v+%oiy9eUm1vCT9aeor(?%jDYRPF6P9&)~YXBytCSMECx{w`(k zmxIwP(A~Zx9tNsMp148O2Pj+D#Dh@xlk*Qf8>s&D9}%j=*ROr)W}v$F?C|e_YIx&& zPrU?6zVW|6wfpFCG-nnTO0v;994D0k&oF5L#%YO!8wxRtcMv&VOXJFS9I%NrQ_yS; z2b4(X=&6W6valr0ImH1f^kPVRIWMjJinP3S9;8OdRH+*&4rr0UadaEROGcWl(FPH~ z+;_PuvShjgQkXMyri3{&XG)kebEbqjGiO4y0zY~xHT)H7J6#B=Y;o>1OFAvl*gP;m?sS0HCTh{j+}l?xb^^1^n69^&lJPJkmGC&NqK` zR3jwE8_ao4GR%2RNaoC(*Cf*bXBe(vPkdlApSY6IW;i`Wux0p6kXSULq=Kdu9K?nE zbVy#lpF)+4G)v!4LFP2{e6XfzW26I8(jn8Yb3L5>d!k_RDrV^=W4n&5T7{+xp0Pv_ z6>RG|tf$M**nW3}16sP+KQm|MObK&l&Xh1`=1d85X3n@^ah-;d*xU^4zaaseL;^P4 z0b*AEGsDJ-Xf%Fan$;6O54VTnpq2BK(XE^455CN$f6_bIz0s%o&#qur2QliDXR%#*y)J zWXxY{{CpAflt>4pkYrlSd1;mO&Je^)mHA)?-x(5`@jFA-Cc~W9gk;W_g!AJ2uOWyXCbybcAc~D!-}reXG)m!MmTG@?-jp^21`c1 zGi2?(w%`--gB z(e&+(i`!2@<_FTvNii$q9O;0RbjbAUTn}geo+wznidlNe*sdcpPJ5*Xw%@&}cZRUA zuw1ab0W@C;fAC3&(Fb6`odcli{|1^pI0CBoL9^bY(2N%3o5`Pss^_5U%_&el@iCy< zdmQokexSMXJH(6>$oa}=5VMm|F}nUwXw?Iny~z~lcE&&@hjjP+e~vu3tUV4zeE9De{Rn+iAp001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchC05F@_J_kHxh{Yt zA;O#tC-{KYGi`uLGByB-9}r;{hNmE*y3|k*0I~uD7#LVYp~6f8n37xvpu+42n1LkA z0l2XNstW!N5aDdD1`Y;f2XQPYD0u=Eo}IpQ64;S&Pjw})P*8vfGb^w_ya$(L4n4$b p029Upr@L`TfE+;LB|MTu0RRzaE5!{W!bSi9002ovPDHLkV1oTiZkGT6 delta 348 zcmV-i0i*u50`CHl9De~_oI0)m001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCfGO z1UE5sO#E?xfmMy+JxHjv0Vb&p3?im2Yz#6W4&wn{kOA-%nC;-tFx7zpsOJJhSO0pj uCV0Fs%v3t$!obrg`3<{sH=(;08vpC delta 233 zcmVHh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCspFc>f}U0~S2z+#~M)&X4-2{0)Gi2$Ht zJ_ev-ZUzwNK-soaRSaT2DUOF&9NUyXajM#0FXEbNH^S00000NkvXXu0mjfXAD^L diff --git a/docs/html/img65.png b/docs/html/img65.png index 0f08edcc6b4ad78ec26e694a75abf78f00fd8b09..f5264e6fb6890196dda28c8b6c660a18e533be54 100644 GIT binary patch delta 203 zcmV;+05t#i0p9_T9De}X$@66Z001peOjJex|Nj600PgPY-QC^H%*?yHyP27pc6N4% zh=^rnWmHsDLqkI{GBP0{ArKG{i=L9F00001bW%=J06^y0W&i*HU`a$lR2Y?GV4w)F zRhO3+!8pAP3@c%5Afph*e#XFX8p>o5W?+2+Wpjv^mn%ToTto{HX7V*4*p3bi3``vz zV0Ir6a~o8EnC54T85n#RmcZ48Gh7IOvAH64C@>5*007nZ5j6f5yNmz;002ovPDHLk FV1heWPGSH6 delta 227 zcmV<90383{0rvrr9Df0=&cpKn001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchC| zssL;u%yCRWQT`$ZwgV7Hnh<9uLBM6ez;yu1zI}m#6~g7k?210{{R3F{7bA0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HX-Pyu zR0x@4U?3H+mzIYYzo~>WxZI2!;~ WniV5o9$Ufy0000w%V`jE#k4Q$wIB`p&M21BU06$67d1KR@#hixwd wV;S$C^$;Gj0kQ$v2}qnvak|*8fw=+-00Da?1oi4#^Z)<=07*qoM6N<$g7DQ@m;e9( diff --git a/docs/html/img67.png b/docs/html/img67.png index 0fe6d6fe0e90a9ee580e1210225646b30c9f0c05..45d906635ef909fa69c063f0d094bfbfb474fd8b 100644 GIT binary patch literal 1642 zcmV-w29^1VP)B%8VgyEGti#Y?po8Cz4MR*Vn9NL31o4Olc4Qmd6VKBP_2heatOh?HuzLLS5@ z=F$ILb}pOU$t0U(R>;Th=FfNj`<^*7`vbKhY1ZffxK;j5*X(Jrq5TAOkIkTylhxIM zXDY1R-5eoWz9giMIzmvL2xjpjOJ$E$q^qe{sVYi`&X$C&$()q>BACUCd2~p(Dy>B6 zPzCobb1{nr^XO1x#g%z>C}YgUZpom0zR!R*cmlx=B`2Tnr^UW58{PYd1g9P$)fYy! z30ghi@X~hB`@s0hGk%A!?r%oo^pG%adG-)zMFbCYifNO13ZZ@Sif~LDGPj6z&L55T zssb_ttIV=JwA;`fq;m1NI4Nwn37*mQx3T-+*gsPFx!7 z-Ou<3o(?*stL#1K4l_=!#x~B12tKe5Q8&3D97A&!tH_#glzk+IyJvQY9Vd_9Y)MI| zP5`f^QPv^7Smv-9Z?w0Y%vdk^6A^sKvX|_Ta9pn)+QU9JS(%4sbcl9N3i=31ir7Q% z0>1;BZ->{ReT-i>?05Kt*hApPw1)&l1Rwkz5{~QjDr>Tp0v^Pw_OcFjgT8;=Rz^rl z33ijAUIiMygV!N;Qp4Gh6DJbKMw6dIN`V_+!)=@u5q#Uk-yz|+UQg=81*&cR;LsP) z&O7LuF7e%i#|-F4c3J2cJYZnWnl*HT+Go*;a-0f1f0(QDyZwvB#%U8TStW-b_1t78 zPWK4o9eW+DAX^@Rns9^EB5QiRISTF5!_qM_wf}-y6sRn(J7&;XI>4c*7Ku#qRAKnE zR$3)Vb0yWZxT-L2m8^{LNc9}Ber}1!jcU({L3qD9QqkNNLe}d4SBD?kIVY0dU`f~# zNnN!=)}lrHzd>KPv!ni}AIn(AGU^hwPhl0S<|Gym!LxBmr?Bo|5zkG8>8Yne?tT$9 z!V{@dp5V*wuS+?FZ5WY)dLpm2tri_pE2T^!qR~!rm&sY3vvkSLYu@XTO_dV?I&$? zbQX~Mxt}`~*ge+JjNXewPMHSUdK|XSbo3QK|y?Gpm@Uu)IU85hTbVY*~j`0%T6t&|}nR z7L7S|t;gBNy=G7&T@)Gd+?wqBL>VqCvDr9D9b!>g7TNm)d}<6$Igi(zxTdf?2iYMx zgq_hLG?O{izr9b?&z%N3w89Q*=$G3cb~}_l?uas6R-)ml-a9QGm48p~8-AV~W*m># zoVcd2{tn3@tiMBzHcue=C)Ka~jd8Y9p9g;&>&qX&oTUY|hFC=NJ@eegjvzb$AU8ERV zk@i7QgH9X~j%47ZA=PV!B}5xe2DMCtLd6H zwR6tbj-PMKzYLFOli@m;!V14W7p3pj;cXlz>mAM|ANAAuZ8ZUROaMF0Q*07*qoM6N<$g6_-{wEzGB literal 2398 zcmV-k38D6hP)s$RYK>h-HvRj+CmU>tbzPof15czi6W zLCTo11SNoqa6sP%9&F5mCICvaz@W%FJtD0A=oKk64b^&vxe36HLzs+M0JydUw|}_= z0aZ=ZxQgHIOKa?87EauO6MIAD?LNx1d~$X;yE+2{Q-@GeEYLHwsIS%T=_-BrgDf<` zmu$#T)PQqx6ISkFRVlz>hfVN3tX5`8FwFVm-L8SDSjx(f) ze;EP}E|xO*2@G_b=E+XHL&jGOxru2S7s^M0dP;|6q9z=iswx#DQqUvqMNjt;Qe6hd9>b!*Oq}qb`R9!MpG^TD*BskfX7IzR<{&+Da^)kN_`LkvU!f;| zPl`%E0H0emP~-2A1=G^m;rg@XPkW~r#?c3$j-kgiI7$XrSK!4;rFt5E)Ayd){#Q33 zHibgedYM?K1G)Lz^Ug;kwKoGDS(IFFrD1AiUxUbQ^>YV7SQb$ z!%;m_itOd|E;JgGGzjOr=omDekp^Y*Dv~_(m(`RLr%;qDHN&aHxWJL?7*wsp0CE7c0dh3!<9j|Ln>t55I;+>!_m5u^!6de4i00)AC zI%ml?om3b68@T1=J4$f7!8lq9r9ED}X?b}b>qRSpmk&1~go~77Xmf7SH!$|NtIAeX zE(on%-|=a$f(?;t!!^M-vlWa}CJYY)x%OAtqkh|ELNnQMzL|N$Rsk*^+VR(En>#|% z@B0H^hJ`h3y&|_hm}%&j;L;Xbg;}@?o8A>ta|tSTl*s7wOz@T|%M8nJaew4qb(oFv zAP}P%#+%UAA2Tz;C$GRiL zDayPNdEWlea1ARm$d5df&!8Q$7aJb7X`>|%3DKwu;`KYTfq3fGFq?iLaOvUn)03oP zKf@%zL_f_Q!0RV!?u0FQ7b8*au0!$o%*2PR)h8uSB%e&u3cXC3UP2Gtgc;rHpoOu^ zKVWL7EYbrq?6DH>A}l+)8yZxYaWn@mlWd?ZdHfERY*tg*1$zqSt+HU4J)Raycn8ka z*~9res)pI`D+11AD;Mm$NN90bbB#TC%w{5w1TI?B!I}%pihs+iY37cAld5bucU?G( z1B6LFK;$8_;LD=Vq3MS%Ij_E&921#WeXrgfM#W&o_Fv48u$6<9rDUmuX_So$4Vfh2 z3BfBxo_3nfQjSB`Qe}_I#N z75hs;MsTnEggW8v_;VE|*nGHd&r~%td%jVALKEyb*0qblhQPe8{3iTV$GlDx$hRRV zc_Zmu4hrs0aPkdRW&%6-_2_L{rXMMR>x>eV=$R^YE7~&$N{mco?$?QH5Ug1FPiXz~ z{VaDI>7xIkmz_#EvKgNkqvM>2N?+Ru3y+Q=_Wy;KzW6l;v%`~V4f{)uM5pw{eaSs2 z=vQ&lp8l^5Ne30yW}d?(@eVH1Usw@}#@Yh3&jl?3&zHZc9P~0$Kkxs|j49mRdkTpw z$3Sc2^sbz+h?u>+oJ?2Vk7v$}_8h?MdLR`e?%uz*JOo~cuLJ(k+a@B&1FZ@FI4buM zE?=%F3nlv=vRR5q@s%G*T6so1k1dEwj0ezR{C|0MuE z8wswoA9?{;Y(QDkz7H8##6xjOp4Rd; z*+Uo9(ZA^!jT+{GIX$)^bqmkg%*6PRvc!){Sp~76{%e5S@Hl*jA}HUyrEFQndZfK% zYnI|+ro7aNP^jnZJm>=Z<$D6Wysfk5>YCld^OsQyQ}8JK5BBj(kgdyZ QX#fBK07*qoM6N<$g6MpRoB#j- diff --git a/docs/html/img68.png b/docs/html/img68.png index 5fc286046de65c9e8b31ebb08b1ae4882b8d51ea..9baf2677c5c1c18b4b730d9f96475306af7946ac 100644 GIT binary patch delta 220 zcmV<203-i}0_y>g7k?210{{R3F{7bA0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HX-Pyu zR0x@4U?3H+mzIYYzo~>WxZI2!;~ WniV5o9$Ufy0000w%V`jE#k4Q$wIB`p&M21BU06$67d1KR@#hixwd wV;S$C^$;Gj0kQ$v2}qnvak|*8fw=+-00Da?1oi4#^Z)<=07*qoM6N<$g7DQ@m;e9( diff --git a/docs/html/img69.png b/docs/html/img69.png index 624c6cca5adf690ef3e07bb0372b12e8257a1a51..4ed82afce8bfe7bb0e688d9795d66086c25e2a48 100644 GIT binary patch literal 280 zcmeAS@N?(olHy`uVBq!ia0vp^IzX(%!VDy@El_g;QU(D&A+G=b{|7SPy?b}}?%gwI z&g|a3d)2B{GiS~$D=X{h=txaX4G9Txc6K&0GE!7j6c7+dda1q(sDZI0$S;_|;n|He zAZMDVi(`n!#N>nptO@$M{Q3t(t|i!vX85AT;K6}MamLKe`iI3hm_=O-Y&aamnJtw*EnyOS80e78 a!0>j3`p48&fptI^GI+ZBxvXSU;qL}h7Al1tPE&i0)qm&5EwkbDhdUwfS8*>07&vd z1X$UV@TtcHOhqOP4C=}bybza(F)#=)rj;>(&1L8WxfG^Qf;59k1H2O!Ffi~a0f|Fe z3j4DA5GKA(Nm&Jz0Won0IsEz*rLG7tG-B>_!@p zW8>-K7{W0#IYEJA)wwyAj7v&{BKRA2Wb*9c6yU61(UhlAE9BMfps|fzVAg6zr`uWu j43THpSy|T`8!#}4)N!4t=aIPsG>5^{)z4*}Q$iB}eEvM~ literal 202 zcmeAS@N?(olHy`uVBq!ia0vp^d?3ui%)r1nE0LiD$T0};332`Z|NqRHGt0}%LqkK~ zy?bYDY<%X-89_n8RjXEYbabSpr2!SXxVYTCdsj(GY4`5k^0JCkfkKQWL4Lsu4$p3Y zR|h2t(?=m#F3uJ`x$K4)fTSZK^W(f#XFb)cCHp00i_>zopr0QvhvMgRZ+ diff --git a/docs/html/img70.png b/docs/html/img70.png index 2539460aa3a028e10010860d8eb06ca22e135e5c..c98687d33f7b368d7b6f9e9bf44df05390bea307 100644 GIT binary patch delta 669 zcmV;O0%HAz2CW5<9De{*KX_aK001yhOjJex|Nj600PgPY-QC^H%*?yHyQ-?HnVFe( zc6Nw}h-GDER8&+$Lqjq$G9e)$5D*Yz=_k4X0004WQchCQ`^Al#tkR8A-&Wb&kgMt@P-LoGpR?{JVJdWtw4 z4l1}55nItA2zQf1?Vz{?q=-14?tWjAdJ!992c7N*A20d+`SRY!3oyVx!@=!a49qQM zT9hDM^j}1f5g73@dk(k5<@Cn8Sj`CNmCT-+8!pX_cQtDpV<~)o78AHRGi@r3^On+> z#@TPzQLfv-(0{F!-Loji;+;f>8EK(~Yb_oqhp5XBsP|ftUOj@Qn0T9SA2rW`3neIP z;4S9NgsAcf7!`z!W?sQFG>GL88K2-KK1Mw&O>~9k4*Os509-Uh-7Q<-!S+SvMt_?j zqtB0H9Z%_%Lu9Px1N34?k2bc=8hKH|vO>jEJXEd3gMa-Ti#w{xc@eWT^nOh);u9U6 zLu7O{PXv*!1Y*^ignpU6a+u04IQFqf>MAUP#bQXjc}Jkn5#wHz)`c(AjTRiDYq(f& z)OLIjUv0Y&aaHj}aEZ#zneI+VizJouBzhoGDq=LTPqu%@bD33e&=tP0G-q#gaUgZ- zugurAM}K%+``~aDrp)}^TFx+vo!e4p&H;<{lWw9XGxJjp7Vg6^3=W}t2J-R+i(`Cv zjH9=oR#OfObd7dJV}Y#fGec3blk;RowmA~oI21lkCOq*^`6tHg<|bl_z1II*2&cZL z^xSj6+eA#UuZ(&rZGMAv{BK+_#EC7K2N+<0{}zs)LTacLqOsPL00000NkvXXu0mjf D+@UyG delta 757 zcmV001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCD1_Kkblif>sDDVJQy`48o&p&=Nf*}w z*;|uX2%9u@>ehnLAt?tB(j|7y8j;HF&A8V1v2CXy@ppLd|NZsm%>zQvmWL!ohc12D z;LG?kmeGbBBG=Rk5Nl#v2d!@d^purDR*(`Wj@bG}{w_dM*dcne0rhg~9zzG=CUA>& z!-Vc@d70Uui+{&paP&T(8b?XR8wLc;QYhol&dzf0Q{JVZ0AK&X@BT1$ceR$RsD z^$iE++A|4NcrUo78}xDHWRbT%?rT-G8ZAwbVd{}uV5%6(8q1fS4Vo#W&62%6;od^J zfjqKPl&eplZ!rUA?x;A z$#Z}+7rjokn}Mk!S0^QkWDKShe4BU=x01=5lUXJhPg4^uRp7H>AR-YeDo_(wHOd0# zQN5TMGt+!R`cbk?QixlU87PvTnve6+REl}ZcUlS(g-hqoug*wl5W7rbAO8skg7wBG zt2j;U)qiZ$knuvWUEJiOW)p`-2DN##DVH4Pe#rEcqt&R+`fC+7EV-Z)7;J97O_?m~n2^jc_ zZ*QM?TN`4tIPe@592cDLBsr)ixyZBun>hL*3~p<-GObtSkG)hjUqkgD6ZN~~6C5=`iJY=-gaAcCjb{@oo2F5*^-}K6210yotj>B(u nzvLwx-gjh+)A%}FBNkX!iRLm&HBq_(F%!yISnWl0|!&u3w*J%|w z&5V#ig^?19ah}Ox#*D!@Hv84;xAxxG@1Nhb_r9**zOU=P-gln&d7gRS`~KX|^L^sZ zoVJ#c+9@R>A|hjR%JQ6u$Oedrh-mZXjbO_hI_?a3i9ciKXe9*A(NXB_t(K)G3=I{= z#%@j9D$K|b0)VizR7fTZ+uB43BEo?IA%_DF;(#XL41mTRXantA8<|W70DwG9&dA6B z`hd{T(Ad~mZ*T96t_(*<$JlqVp>IMhEG!HS4ZX?UYHDgi5fS0mbrY(oSrl6c4Go3h z(>z0khc&U_ABf&OciKVZIJ5VPh=^RQjitFGI+LB{_w323ZPB<;Lth5eYx;u-%d_L95ZZ6&`3K5k7_ZAbl>_l#w4_r-AT%L9Mj@ z>Ys!@IN^?D56QEKV7U1{ZqwB=-(dOUh^Dg@woeLj+dpG@T7<*yRG$Rp1{Z6Vv_0E9 zSKQ^HD@38}80-bbm{p+=)FlEmKE8}PBy2ks!=c%pmKc#-n+^az-Z1a8r>VU^ouO3( zPdk~ybY34u?*zV2LNrITN_YqNCISXmB92*g>Frj~x3~QgZZ%394|F&;(xVv%zZQB6 z@!)iO$*HpV&wl!toBD?zb{t4bFN=I0&uqROW{Skwc(Y?QGb*WzmRfI?0T=f9Wk@b$ z0`UR6ydTgbn-037_4mKRghr{MKbfFW;uPb5Y8g8iM$(PAN@N*uRL+Ul!&SiR1 zT?}f4HEhY9y0rsBv`EV)h>wVkjRf#-+8(C4Q*v8Ru@SFOfrY)7Q;466s`Y+pqKkI8 zBUQ;2qvO-#EBjeuTXMARPSj;p3qCg)`H#{pr>x@Mu6b9OFueScfjAJCpGG(TBod@f zKZR4N4vqYxiiWxGnOfRCiTMto$_*(?P<_jdw%jqw3c^P(p@o@6mY30MOrE9Gmq?Y6 ziVA7`y91RjK^17<1wCK`<1$ILB6o(H*>pek*YTyNett&}kXie*7pBv5HxE7b!FsBY z6JSpD(v22~{Vgudik9u0w~+P_lE|S~CK#jf4Oo1vc-m0XdMGkZlp z{;Nvoa^pg2(VHnAQ$M~|{=@vkZ&thL^~BG7u__&I{(R#hxa)AJxVz%|3&d!~rOk2o ze0Zcn+T+~yCfU*!i+*&~M%I3t?!>T7js^^B^Y84WNG+E`&o;4ETx(g8--ZiN`n5vI zpiEXI@z{e}qdV3>K^`s|%)!p{cdZ2+CkQu;+e-;SJ^3`^g9mA)ELJu*q+;Tz0HVfKp3ErbcW!Q zPql|&0x(9UgQ2g!l|gc#eUG~HFBKWBj}zqT2fxFwU|n%M!C5qS#N7;_gQ`c#PdgA3s()T z5Q!Od$4^FK`py+7rYmIL3nA;FSt#{pMv8KcDi;xRt0dk&86mbpQgByvcY$Ohiz2pw z5JfG2;f?on3(REJf7EIpi};Sl-v@5@boM(L|Dio(0(u|l7sBv`@vp0cjIDx(qK3nl z3V`^TcFB?VJrQNd*Z8&8up&w9M*S`8k@@#AaG&&c^D1_W9BEg8nd0DsL+^f5Rd8l1 z(8BV|(Ye@d*&dEx_~yoc&b2Yt08yO#<12pT1dwM6x3|_WXs8BLs^0TgiRHq0B_&|F zr2)6s@m3}!_rB=LftuY62w=)$Fu|I8vHp2?a!bZ(Z`nt$#)P|pQ^Y|3Ok?q`|FZ4bME^{&!5VfqvVb< zjj}RNy$#FnV#F>vc*8udlQ)3Tl<)7Tmwv;K{J*L&>mfAMY*(3?n*u>z_jgl5H6g(b zaiFwtZkIe4dmK?;zQaw_4J_U=2}d!g66mJaJ$Pg8nuYP2f+OY#XidyREy^!vAY6X~ z@jE_|z-^yMoy}0wGZ1^ut-ApFhOE<8wDLMJ7q@JnU-?rTSzI-pkto7YB&a>2rVqd{ zh&JQw=PHDKQXM`=DCDx#6J=6S{ETg{2X0naA1$-R)&c4}&pY2kRcU*gKIb-;N}=Q! zDGYA77|wMTOp+8jkW|zLh;0vboP!{X+*$DSaEj#CfG+yH#6!F^k z+1`&zRTHKx!Caf|yLnF92;4bSM_nh#gOsBk?+_e5?OVH&s>c*CkA+52lb!=P#i6cP z!SWtf{8);sDh~TBPrCyB(b1}|wCIwP6K!H){@TfWtL53=0VQ3RqjvNj#oXdD!@O`Y zjHeyKzek^tm36kZn^a%a0eM?@B!}M;adilPDRrhC>ZgiRV&R=P24xDWbJz%kXFR-e zir4qr2>w~00Bb)Qb7m4=oqmNkvXaGOn@;pE+4*Eiq@IDiU!bh*UCWoaw}p@0bGAQW z+NTa0fp~fa{{aJS&Mdz{Y5@!~;S0tpwkfkvu;&+LGyroHqx=G0O{yZz{lI`cBnUK` zo8#7+gGj7>om}HhGg!5H=_r|YgT7y zMAhFEo|V$Bay<~Qdip4~IEUtNDwQ*k1Y)F9{q^2o2(1qU8`Rdh;u3G74=QFfl5c}k z{lG{ZAxi(@*-rIJ8-8;DA4k@cZ$H$6D)k36{&+o}GbH`B@UCf@LRVGZD`n3x{%(pn zVc*I0AmrHgPfdv6j}qrl)g+7xArv-*mHCKwmy_9#;c<}jGZ}d}UHJ%tp#D(=-R)ja zQ~_N_#RUZyrI)ex-B*gNNPe7u?TE4LJsijx2kDa7b3h@Wy%314qTz$uupViG86ZzP zjYCC3*sc}rfs}^e%U|3e7yL&Ye5L%N9d%s-@O1dxxJh|uC7BofA=@d%W|tLt>^tp# z3A1^c^sKNKcRtYPsjfV(dncpSxRh0C8yYj5A3PmB`Kr9L8RoFvuw^&9+baUKLF(d+ z-T<-q$&(9L6Y9utB;qnVuHZQ0-nW`Ww@J5jn5)??v)FGJO7K-7uxX}p7thZ86HR-Zl)M!l>7V=_8FqUH?{Cfbs1V)7DeRx zujB9oiK7nazxxE&htnJ|r6?k#ee|7c#F70cvxL6rgt3Lh>o}N>eedc;oP2X0L@u?S zAc-#j<9{YUcEOV6HnGHnZ0`_^N~e+i)lK%B+iZdU_07Zh+d#?Wpb>YIrxUH1M6SL` zmnM{u7uMB~!gTXM?QiV9q6U6U8gRZg2I!oqiR&V%9;w_J@*RH7o=(YirQ>blmk15s z%0I-}l)E%S)V}x4z}^-IqjRoJt&Z&lCS1!n@wCSIep((5e{m*{j99~ollCmaYj4oy z7mJhzNcz}g?$R9&e1(uMl4f=I9ffF?#Q#!lO)=TT=)tKd+3sXPo9UBWQ*I--EvRLb zM-Z411{p+IGyLPKmcg1CWAk+ZkYNS@hs?gO4Y%{)^J6oz{Z%^$mC&B(=FFlT{3;!k zC6jMm7F?1zG86*}5m+oKiTCIYGO1mk_6vZHfPP1RMAA(E(IW&w!L6_t`ET;H?@w3l z99W+U4z>wm4uFt2m3m*VDO-GtFZw_QzZK;GnfVGVDy)>86o6r8ur)?q5D-;hO7dq5 z2_rZMnE^gFk+sD0eY@U(-$nqm@s$NJRfBlp()&%S0f3DxJr29yQ1oAsE4%ykC%R?> zF4+p8opbjXs=9;F^|b$84@*O(68AVmO2myk%2t{EQBySuwt}CcB5D}aj{PM^UFq&J zjD2+JE^swNSR(fKg~->CRGEXmo`C_nAR!CeLXb$15dT*{3Bl+xlCyP&+J}Y%lSiNL z(9*kf8DM^V;=^Z_#K(LdSTRgufoB6tiuTV{3_sN26OTFLF@N=F`V{5_JuLqnG)K|x z`{dqxIR+=&!}4tfCzhqDI|Dty^evhH|5EAyd~%R%Tzgci$vr=^p-xwKr%Coi7pxij zsEZ^EYNk85zc#jGFjYIlY%PuE?J9YsG!8}$lnx}8o-glb?BP>l2uSE?;J`3;!Iygy z1rAH#R&aWB>kX_v}b zO0oXT-0E@T?n zVi9%;jYw8PBDS}|-TW^&Q{k0~k#!6)v6;)?q_K!kDU#){GQDWT6bDG~cJ`q)SL=Rh z`&XWdr^DWPF%N%ICb+paH+oGKWnbM~q2D;sYPL9@__{*N?9{S7gUQV38I0uLeCo1)p z=mGH9eqM7&kikfgRRi_#h_c;k28oyZ-?`VrM-7 literal 5090 zcmbtV2{e>{+a6?zl6{gbBq1cSjIzsCmNAo3Lq$?Zmcd|brR+_J8L|&!WGTyFEM-fU zu_fDBqA-RT$-cxp{r~Sd-}j#Hd;j16J>Pwv^E~G{_kEw=eO=e@cm1NRElrMcp5O!k z07uPCjlci^vmgM#)W*TWc(X2cxiS*r)>k0L2L}h3&zJ)j7Yqh-P*(@7g8KXW8QIGvr=5xwBZ-3SiqR3MzQC2 zL&yOkQ*+VW$XDHEwj(9nup$&n+nIfIiGU z@+wX_{Amr7xYRf6m(!6=99)yU=cVa2O~HlZ#1(&yPJSG)wkuvzaGhzMFt9g1|x9=VbSXoFqqznL#uDK19tC=a-v%#;7}vG2Qlk>ANpDE}JgPwZwndHf&Bc`q3wtCU!f+ z0suI7%=w6m!T1L>sD`=iOpMBUq}C+|8H5|{<{h%}P-Fc-qXhw(?i!@PbabAU5?qZ* z$&}%D_mMXrZb8YDhXk)XJg*lcWc-xZ;=+*-C+!FgUbp%?fzS=n=K4o&$&=F*gv-jx zQcU&eE;o5}ByUmf=zS~PHS(>X3bU7n*GE%K){?_Gr=ky6ldMNBH&r7P2^{Xr@ps8d zrZM>U15pGZ3!ZVJ0030HXH5GgT}oxXX#Ab*ictC3CHglt2Z!yWEGNSD?R3L1pB+>aNF0L zKd9MClhLMO#kG_g!koyDJ|cSiVpV#q4k`XPp-Py^r=oujKf61jFrk~RmMpaE=Y+zd zcNFqRd)l3L>92rG=bjG;fPu=a9|ze6joAl{S*W>;hbc7s-R}>4#d2`G`xC|%JR;sp zqH7EUMiaIPa!nhBNgnA?iF1Th6-r{UUTvRGryuRe3-Q21wjH-7s{5xlQHn_fZD2 zRxsKzmTI!HJD9+cy|wjTckx#JPr+7&wpn&6^C_tZmY9pcwu|fU6o2=3+qSs>dL`u{ z$s;apevIL-jLalxC_wjlj7QW=#f5DH=kRw3`{pkRJf}gI4@t-a06bB3!yT$P zxmxK}4{zGL?Z+3BRl{4wM`(J8%7k{D&bYHZU&TtIin=y4`9YEk7fwxfeqZrYU5KMD z>+qctPULi8aq05OLU-BW#xnQX#p%vxjB*h)H1+K!OdRYf9n=CoWNvO4RR9JmmW zw(@0;)87Vut5oe8p^~Nig=}7a*_!#LWEyTGy!7hOL{$5=0~@sLsI$no7y>~Nw$Ni< z@%Zo?WaX6BUa5P&!ul(cef#B#^SZ>$me+`l!vH{BJXRKUbqAsvwCR&TcbS zT@S@9?t*=m^-x$E-~jE5-I74Z2Z@NBJW8hp(^?9UoQ~N{m5L zZy7}hTyB4i9X^piua!>X)40zfQ9EDzBRp8y6ZjFnfiS>OGK=x-3z3)o5B~nB%&5 z1JaBT&66472mLNv;dLq4KxJct8VrhF5Iea@4Xv#WD8J~p(G;lo6aA|8_#!}S?Cjpc zsrG@_$}a{3%H;g{2RtU=MH)T0B(xcutz%FyL5JRyyqhMsTQzk26s`4vRlV^aGJ;MD z>N94C>OWizgN*CRM=)e9iWnSX!gCn>p==2YH%i3Rn1_KAiW*~-Yw(p}PCMd~ow?d3 zf5p8Mh7y7@Yh9>@;QH{|Z1XlA1KY>5N`fL47j`wP_)4`#(N~4eXrW0dof#?tgo_Cu z1C%(XBu?I|vArABX&F*`X6frb0MC}Wl*Ua)h&?n&r&(WfT5R+THKN{@$9sxCV3wj1 z&vdL0Drv4XhC>cXc6dNo@g*!^FP1+>EM)M^j+Ns0Q*&;T^!d^QQ0!2p;(nVAT;U-s z;8|uTLFj*zVrF7a#S%dp?Ea{J;S(zu0MA6~9*?*Q?@)sWUZTenOOZp*-g(%V zjzw#(oc=fRz87d4){WcVskkrJJSQ`H#RfgIy8PwXl({p>q8tWZ(fGYlgMW>GZ>i?H zv6|=(7mCw|4yxg|q9AJ0pG=FFf1oCnv1IB_nNu-_m1JeJ;409h^Uu&<}p^qF!? zkuzy{_J6K9h8p*@?(0%N-~|c0Ts&VOhI9 zvEY!}=rl=c!jTc;Ti>Jos+|Jl`$oqiwd@x=qHk7{Q!)1)xxLKA zPZKhmu)WhL=wjBJOYj)#1tsE^+&F)32 z$7(O!%fFd2t6p^E&8-ag=KP#krAGNuP*PjGSk)Xv5R8ag%uphFOV243*)|06Sl3+9`C3~us92~ucmV(^}J&NExYPPS3L8GQ?Q z22#8j+8UYSbQokAXnZ1IpX_**QlsrJ#%tfx52rRq;z9CDAGE;}9&m~%vBPa99-^C_ zl#{1#vDW96D-%f3?B~1W``R^H9AsH(bWBXvKKFS7zhb{(dvppV=bO=gSXL9Td!dOk zB~(8F#1zE}7_>iQfB=@cm33z4Ws`#owaW^)1icqcDb-?gM}5ChTkVWzkT30hYkJpI z>=R@tnq~mzKuiMy?qCD{r`f z-iw8AS(aV$>q;_k9uIr~gwRpuUZoZVcIta#v+Q%72xk zx=s@!*em!d(}@|xZe{m@haq?m(+(%4Sr1xY!;NJ1W%*jqOw^$$WOK1VS7tzQC;N_m zEs1&6OVOJ^7K}46rH2{LPfb*tN0)Lg-bjlqt$NrR0?y$oj=BEd5Z1lC7~$NtI*D%c zPDhM!ud)%Xr>_%(VZXGOIvbo=CNcQ;7FuFyYzdF<4~{FR71;)6Eu1b(>BT(+mM-gx zf2+^E`1(y2&KpTCPjUM31s*%cLRPI`rpq?AbspPPW}2))4Y%|-*dgB*#yGu%9|eBQ zz!YID;&Qow)IQb?!NXH_BjNtda2o@^4BGp=0UM;F*SfUdXz2|84YH5_K27wm&IAy|Epj~$pYUcBY~9w1i8(ku%rJ=VDLtcTsD;J?~o5}}SO zYR!4i>AZ{rI_G5`$_`J+w~P>pg2*0RtUv+v#K%izZ!=~1U~bUB3``w8-lkXK4@$*K zl&rVL5p5xLFo-g{+p&_~U61Do7Fgk9QCOx}?-%awrCN97{+h-lVUps#`9b)?W^4g9 zdGh|lZaI;?E%Pys#95LB!W~&OdpsBcb5L3gdP>sqM2c=HrsT=1-$UN?S)Z$nTKyPa zDZat#yH0AVy9&QG6?#12#J1EX<{8&~iN&u#s*2xNu_PsP%^(J&B8TU8ujKe}-tdJ; ze-goeIXr;{5qYut0c(9npA>~D3CEpO&Tsk6+_?z7_5_BRSTIR{vRGj72$OhirLV+V6>gROrDZZWf=e3MofVyrHk>YMu#>MZw z=!(`M_h}6oKu>Yx#;-P?7q^Idv=sPJnX#B*Xqu4F06?@=bLN0p+`DW8}uiKV9} wIWMGgfIBtb`1Q+m^q-YeSg#>o;pP4rYIq2{(+pv{xJ6o=LnGOMq0wwtSD8#1wx1t6D(X<` zA$EE?yQqjwrLw!axZ=6kgM(}q3-Dk8w!#_&Y<{o{us^z}RBBOC5p|TBo}OORU*zZK z7Znxd>gt-_osLGMqdKDen*EH8jn&oFU8$}zGBRu~F7_dgv1Me8UmCO3)!D$?eD(9- z+eyFyJMLUWS#h13>~rJd5|lGToJQXz%w`6KXP5}Kw9D%Ty;Vb8dbmH)*F+(6^W6$N zxXrv+6zeV#_y@Ll`y)>TvFJL_9|Ii$voefD%G=_yw)GFHo|7fASBso!{?KhnP2EPr|@;C6f}} zMDtF=;3Y;~Ofmhr=>w(3n`AQmm1Kj9u{m^w6dR*+14KLHS z3HM+qd#3n?P@1&ig&X`;aj`A3F@DRo-M9I4z59#iYu^+!=Jl2Gmd%#Yg=VmqX-zXf z7+ztRN_%~~b)U}Xy|yn#%Of%|Cq(xSrCk-Nf)$obU4Nl@E-tiJJ>y32`axNKg(zfa zzN7w1*P5e`roBMg&tV~Gk?L$n+mlB^_B*rqv_oCy%B9N7-Pb+RLjRs~!G)s77D{c#G@lApT2Gr=3L}4C%dNuN z&y+>qXIgzKJTM&QTzz+l5Tk;hFN|c!z1lGRtRq4*H1`=PwaJtrJ+JmpAo!w8tNtvV zh^0}&m`2k>j1nouy*-}7DAODlHGh@boEW_#Z>YNg{nlbTx3!HfN|r<)tQS59G3BOY z8;Mu6jmNSa7kfd+bf4;n2QZ==JWf)wYkd7nj-BwQ%IZ1*r!9{EU^%*wtDy~38Puwl zwIA|o{?-NhqCu+G&Ufi3i0qoP2|Xq! z#$w=clNyM5PONBO{vbrkkWo; zNJo+b%+7ysmw0+}nK(5yb>Uvfz3taA&BMb)B0Q*`_B?PiW;FPPR<#MS1M@kay{)mX zZUP%H1L?!90{D}0Y7_yAoiD7Y4SLYYGztkWw)eW z!r4~J$3a>YGwi}zXW55g_Dhf$ZwBK8d3AHms-gkY$2=y1Kw)7XxL9sop+~XYT%wHm z#apoL(Av^aO{Rxf=o%@Ow(=+6!o*BHk$7)w-3-$-f8$-c8d~5i)l#Q5jIiHWB&Sj` z!Ugs&{rLadVg?d+b-SVx%K_}3 z+4HI7?M+=PpVASA?%}}<$-!WpjQnF7gR0~@dzoudORH}It-Unn5q=!ozh6b?V7xR934AT?vqb=w)-23o}3exM|)C%Es#z2 zd+zlM45-m{ZJsvF6OAkX&Bea_=1~hc`X1_@s_1h|P!J#bhw+AO9|JSpD~`WX*rdy2 zSv>+^ztdd~6duv-DI7;W>fZQ-d}<_?5zQB}>#v9$u&`Kftx{z%UKdUo2$PvZ9O6)b z+xUR&KB+kbz~j5j~W3lT^=;_N70-)O1{P` zu*o%kiY|mmPdjmRrGpjP9&-fj1p8xlV#aXPn2F-?hD1q;T~W|>kczv zUS;-|qi$dDoORINmEyx~SuNV`l5o`)7Z`kvleqH5KV{zb`S%JAM}q@uln2@(C*v~I z{5{t(jJJtXmS|YgY`A@t3mKB+?I9ghcdaM6qbUC z%o<8@{?)e~GiUN>6P?dnWZ{#l@eV`rjySt$!m+Bj4vg?b++~NiC+Ypz0Q)+FlaRJa z%xzC??#Xhb2>zA`etcp^ZZLbYc+tgQ7eYQoxg!;+RP^9QwKRe*A&h@Nw)w|Jx^V*U z`xJNlM5#eu#W(iHGn?(!Z_FzyLxTTctt)mgDBnbkeKN^WKYeRL8anGwJE+j(5B|uk z!h#RDX^W30&Sa8SY3r^#2p@!Fdp59Jxx3>ZS5MY9jMxXWJyZx-SlEZ~0l~)VYjp%S zm~4C9;jZXYxZdt{>=w9xNZ!4bgR)1<7_#Z~?ias`yQiMyY61T#duOU$4@AvcV<3E+F``Q&3rP%gdv!!bS?|L$?;Yl*cznw(OS(X-AN`#R*S zF(fg?b5{3C&aOEGDv4NnskpdsFYA4ZHjxlJ^R)R*_bUuIBe+V5t>TCDUasrLbY*6o z1of6x`t-e_F2H&vKeI4-X30`EmdV5Pl9=)gy|1{PQ%#x`y;*+aw$1P=NUEh^+qa1? zc!vp{Xo8-91%vK*88&BA0QEeSW>%HB&m;5x7gS#-m-bJz#C?>a|pW+_W<`@FXd#u@{^eA5i*b8LG*GMO|p zsfEW6_T9k1x~GfW4wtN4_Y>0YCqbAyCABJgfslv26BtgG+>KV_g zr7j<=6So(i^@_mlk483J|8BptLzMZTdUe}YjBW(YU4%=@`17Kg9}{`j3<`4X-ktB{ zuRR@N-F-hX<1+^tFA`HRzpH+&*v6Z@k_7VUhvZj{fE;a+6Z-9KH>>Gy@^~9(A z-9&vvBi6m3W5F**2ytUWNZePTHw{oz7r*LML`D6faE4i~6OXQ~~L?P5d z7i9%679p{wW540B0>zWHo$qX<3w_7^Whs2e-UJy!;)~(8S`_WjcHOPXB*_*<#U+wz z0ioY0MR-Lev4XA`?UeGs$4)Qp{!gTKJ?5aywg$mQ=YmB?|GK-5Wy`(FNcwd%J3d{d zNB>jJ$a$4jWimIDA3srXuxV#&!6QJZ3?GbamX;1ZQkUYrx;k#U#F}?pMY*7j=~1K7 zuCVDgc1Ucf{^q5VO2l6^pnCohNBWTBBh^6@75?2-5{~>pgsSA#`MSq6)!)y)u#-{; z;2mmt(KPMvm-)*$C*4@RyD~e!IBpI*@OzszEGugpLR15}Q3^|yp<6?(W2B{$M>fXv zm{DDj^Z;hleEm{$v5Y%y9{X|iQfqFlc}Qa27eE7vs|D9Y(X0Y;?@Eks3j@{Detr%S znoM2|(1X`*{JA})Di{22KcMG5r*B)#TuvP2Fk0IeW+M2Tg8u=PGE89>p?b0QI*nUL zu}4*&#b_kN`UpVaM2RT;95G@P77Jcz=Em&mimezZUbYZlYFpP)|yC;t{Uds6=+DbkJn95=`7H61%v2ykRlBwVVHQ zclZVLkb!nPe4s)w=4`heC!qgRTJb-xQ~?n3;7rZ?LJyctg^INL>?;h(ryouTlX87T zAaH7oI`O&~%JiRc2mx>qy~z2c1FE|oNN8$|K1i0rY3TqOlbRCV)cC`(6)Q#O|5q6N z7MH$+&k^5Kaa!?4!YH#IC%Hc6i+bk6SlZGpIg;Xc5~P6eW$-2pRP`tQ%ae*mMNY~6 zrHy!S(6-kQ5am_xn#n_J<^FvKHg1SA%X@O3?IstX zVXmI(56^y8GJ_@R44v(;Z|NqJe&Fw$#o5Xl;ET*ayrXVR(@&Q5aR_o$?u4Ie_Ro-K zN30UAK*f!7C%kWa@CmdU1qM1E;f}oh=1D6sVF*j|@s+7aop4ltlq^{db@RGqc|^Ee z2Audf2f3{3oZnlNi1A>$6z{f6{e0=pvrkD^H;U2wR1>a7CT)6N&#(m3*5ykNZ>w f4koHAw=QkKhbFv7hInc@<18*SBnnY#x*ATpG$AItk*znXYtdK9hZgR;69fV8+lI$#=$nHISd`ha@{~c2Itz8hF4i* z@)#YFQJ&MjrY@uo{NXhfbdT&hb)_F?Jk`dl1q20$DDi$ziy4T8;9L0-1|y3qSYZn@>JS(DLE4_%LYqVU+xH}Jm!oZy6>?X zg#t?Q6Hw9BR>JJX4gyIT=2hTL(5djZ&bmY2>tfntt4Zw^{hxK$(>r zC*S2iD?6$Af;-9l8TcbzDCvMKmwFbe>TH3Z_%t`rZ&QJgH1&{p3TKYZ)QtNaA-9Gj z{juXM&}N6V+Q$F5ZWiKRq62DgcMvEyePe8u(0HTKi1%VB+j*`u>ft1AiKMoyoF3;@ zbN!UlCz>QVx;0$|98G`xNki?Zga{1oY*mns42}77T z6`c9zZav|1)^TW}uc3>;K1v0yq*sR}56?JzblW~TrmEd-ab7b%+J;Aj%x_v%<&%db+SCzL?GSH7=$JV-FaynVvXQhRl5g*& zIHq!9>eUFV1zk%tj!y_&I5tOw|HZ@GStuZ-D5iPYK@R%& z$FwFX7JTWa01s^&HuEOqLD<9X*-ADC)+C6dIEfm231~A_L2+Ag=!jhq2&2Q2VjT%hF;nF%L|EOn#VQ6 zDo%{T4pECFbma2zXMJ-M9WR8lp1difH+GoatJ8McFFV08GzU!zz_w}r>HUrMTI#UV zIsTZ^pxjC0(-`kNl~KqnGj}cwcg9^qn%-M>suO@Z&-QD6u*{=$?KOVc!Op*g0xpuf zj*~VR&$G{&@xDFTa3?^a9c{1GMI})nVP7{ZSWT!!dqWA~x?X)a^C{I+?Wpu&Z034qVEN0g{kv&$zznE@9C=1HX?o+BX=dWIzmY9$_ z#Qz^42Vhry^5SUAGM&5ll5^V zR*JHcB@jG$z7R+5r5PW;_3!lUm1ZEdCfuTOVY8X0{c-YZGGY-@)@|7gOb^W2kZ1nL1j;uJi*G14iLh5 zki!4xc)c@<%6A)%rOltbAS65ko~YxW@TOK5c6_;>&2k|~7I6Y6;le#v|BBRTblB!F zA+*$*ZqAQT5TohdieZ~zyW}Bf&Uc$1fN3^_r5OQADCa@iDlBQ){T6=_JU_Qnd}}i_ zYd)2{zF-*Jwlmfk=RGA${7E_??cEW>jgb~Me_xrn>R`FvGn8a}yM^|7uzTPlPvbEW zv3^RsM)M`eeH3Dpz%7@t+Iz*`X>DzdzWbccY1EeC>8GJ(w&1LoYO6mLM}0HtU9Q1% zSpT?T&up8z7rp7w2U2LM$9jEtR2_fM#m%^12>RK~`Pj_-Zh*8K4CO&qS&3py3|NjD zmuL*ffnVTc`86)#+}f4IMUdBPp|Gb8kCj)lcwM{VVy zoZwGfy@EO)n(D(_$m@z%$g!~q1wFDNs68M0;LPm*I8@VX3%2_tTT57)EWaU)_qRUL zY8OuxhZ}a!FCZG-S{k`G61xIeavqXkrJU}>Edb{~D7V)!G)b>PEiEu2dQkI27ht&5 zsR5Ao8a~-BaJpt@)cG+RhV65oj{Cv2kDw7LmSH)O-Hx;V_9S6@&YaB&r%RI$McDpH zTi8JC8>W01DwHV`q7}@;I~_ajJ-GdpoD-Rcdq|r0#e73y<4mMq3NFQN_B{x5NLQ5(F}+1xW^9s0TS@^00zM+xADe?C9UGwI5Y&|lve zy3_xdOFW8)_d*b?>SAOb4eMlIb^8ca`E5f~I|@i4vPMB>4kkbXKaZ#mJNB z>~wx^rez(gwjOTeJ2jk7-P#Vz;PqHy!Pk10dE5%6w>{1^Y1~{3w)a#;o6R}jp}iZJ z^3l^sUAniTQX8_M{yi7(VM$z=MvvI|C0Mi=(Rvppuy!(PUQX1_7dcbTw=08&+C(4E zd)=C;m+qM+&?NDI{v^$ht?M#@M84}{iJGO z*z&5K?UMiKh)h;xIgl2SOnXnnf7Nj8(AufUym#kgOEPA5z>9M6e(0sC&S$`>al-ry zPvZIFxU`CPNKNIp_k|W+954Fvukc@HlFG}5i&TAdcSQ|UpyUfZiTCG z@g_J`&bAz8mFRsP#l6VCQuF`=eTLEfZRQuz8rkCeXHKbhUuJr-giP0iw`1SaY zRctqFUc!2?1;AI1oOQQtP$_V2(df>jZoLhHq7~6lw)oTUA0cF+mh1r>K!bwQQ#buz zaINx+WL`38s9&}Qk;MOd;;a+0ThbW*&XCN~0%|2x+m17CU8hsnMhNl@kK>>dI*W#i z%xjTD6_*D!1~Alhtw)#p6)It8HmW#ohFn|K9rBfRY(wQ+A?L;-;>L02=n+3EP%vBe}X)>a{QB)*0Wj0-X76)E;3Rt>El<2@|b)7Hdg+$ z>RKeS6*F#r#-aoW?p12PjwSUvoobcA*3vi14aPu{$|<+)iqfF^Zz`PT zp?l<@#{XNX#IQ~+GkHJV?KN-t2pMIwh2argk%+@UkpkrdQ(a585~H zfi=WM`Zplz3d(qJHXK(mI>=c1+8WZzvXOylH&9tSf6U_46VP@?aGEU#&0>>gmR)5 zO%^u()OOy8aIm+CTgZ%_&_Mvt?Q-pYv@4Ojb{5Cvx3oy+YdFkbjKs21^USJA--|8a zEU-3mVWwzb_m_bNsbVCT5l1)-vfniE%F!ji0@m^gcf|2NfP8=1qoOC0T$W3{tAm5~c= zD)n{*EzYc~;L^FvtG=sd?Rg=_LV#~!rtZ0Ik!Okx80!Pt zPMaDUWON!ZoZyDVkvM$C>!FwvBaY2{pC0_DJ1xgZaKr&CDjnbs%T-t~XkU$;$FCD_9I7hA#-UBI>ub+!S-!PE&94@w$3&P>u(+YyEgyI(3-1HX$?zZ7k-cqy;ib| zP_wsa{%yEnDt6`a@TVefoa^E7Fo~D^WP_Xju%N1^N0(rwtA7scJ{g^fl#I#pA&X$|ht18-Bz~1Mi^s{pm}pyxL;m-6&)z`tyCva7c!)^(0DWe&bEO~WW@_m# z4fMAM@gu)&1-2+t?5Aj_x_>n7eR0{9y{DrdT?p)&!$6D~5uRj(-;>yV#*!^Sk#*r+ z+qNL#yd#DCGA*{~dP>%st%isNI46tAYWcFUj3oOu>})OWt$1zqyg9PS5eF6cC$>)M zPB~8$ut#R?>0@}FBk{~l>`io0!Q{I22<6p2g$VcqPR!%mKd|qM zWLlArFARa*R+#4B6(WSu8Otc*zSQ4p@_DD|HQv_^ZK9uh7E^sae*WKk-~5ARm$gH@ z=3Dh-@%Jbwu2rsr#pV7Y)Odp6?~4eH_iiex^Csc{C5)q0SFLa|Z{FU4liJE<-q4(t zik*V(gvJ6_AKcUE5H&7yon6wUppX8#znPP>`Kblvisu(`N5kM-d-pO6JfHMSP7F*w zpeU~gZb;YQ_h!Xm>Nz9s!O~ae$IeidCLHsMZo>6VM+4Dy$ff>?u*YDp@v?-JmQI_Z z_RA%3*zh}L_+F;(+PmTQ!#Fc+V?dyu%Hg3MDdFKc?m{gr)LlF#ksa^kK%jxXTXFe*;$9mlOa1 diff --git a/docs/html/img73.png b/docs/html/img73.png index 6cc3ae5c543f5728efc2e11ffa2622bae2cc0a60..82b032175f3d949f0f3958fece5e261bb789fff4 100644 GIT binary patch delta 692 zcmV;l0!#g+2EPT67k?cD0{{R3G=jml0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*JJxN4C zR7i>KRKIW2Kp1`aN8%(-n}mPB5p;+^$iR{zgS((Et%6YbA%F41qCgljn4w55P@O0= zsl?EMwu}r6l~_6zMk9tWMnHtvJix>T5;NcV?m|qX3T0qGd5Z4tyYIbs@%Q-*j4{R- z{{t3=ZD!=Gzlo=n-Gdy6R4WX`>AI99SxhdP@t9@%DFbLC6{__FP*t)d9?Q8cc=ZD< z+pzj)UI88{S$`78(2e7ucv;y?jHXdy8Vpi^*dCPMb z6iIL0MRh44QW=<8@+iLj?V%Au%6R^_%<_Rfd`g9wb@JXzv}kX`W?yL1`n{TUo*3`( zkw{I@f>DeTOa>|Av6M|w%Nf!Ueo&1%u-RAaP|g!2U4OYb&q1pWPTK+A5vh%dV8*4` z?DD!w8O2IQbUG@>%qU+sN|;QftkliSWhY>PvY5Ugm zvTjDWHWliJ`R0ANG*Yc3Cjzd*{9e|zf_qlPw(q4Fq%0CVl4Vxo2haH@g3B2rLPrnz zOOo2%0e>5852Y$|u!&@b8)axuDL&)`bfl2+yp&!45VuEvb;qqOV*R3zwPz?6i+jtL z9B!3W?O8t`Set98E$W?mdb7b}nKRnKeGKotHmn`X0{-6V?8DnbVlY!B^v^cYG#NVjDV9)G;KiU++&^yZ;3genMy zrqGLCb}1qr3g)09R@~slOTnNEdJuO10L5&nu(TAN$##F)Mx^zk_`%G)_vU+VUS{S^ zfH*AiW`RHjf{xLRAzQORx*!9zO)19)MhbRUG1`J8M}w@M_hk)}dCaHdL+l5Jk7PT$ zt5ijX`OrP9Hh<&U`Ymd~!_)lrx`Pn1nH{W}{*ht`*9ZHvY3vtPS7f}2-7@Y);7iL{PaY5)y5zP9G02D(j|7V=R;xu(@QjW<56#xI`jk(Gmd#lMYic|;pVc5jy7 zy6=P+N*kwn(}7G&OLWXk^fV<7X9oq#z!qG-p}IPJsrs3KW*Aqj(>SMuicq+wfLu;bQ`($1KP zt`aHt&VR{2lauKFQ`7=JwcYwb_;piq$KU{m*4b2PQG_Zz++=*b++j^LTxoa&qaZGn z;X7O}omvjwLb$ziOe{7<=%Jh=+!UVqYutyAaiDSnQ(_5x6>)B}cEk)-oI13PI%a?` z${5$#JopcXyJaXU<49S;ZJBcm!frgltZEi3NPqhtRzwKN7X>GG9+)luVux5EbHT{8 z;YB(wDtr^T+ZKplY0bpiAU{Nv;NT@eVM_7l1B)6-*kUh;dAx#w5VN+`U`0?lf-!yxf( z4A`B2l6NIG&})P><<_|b2Km;#ChY3xh;z7z{w_6Z8sVI9VPr9A`cNG>?I8!wLqFKbW@{ z8rYOFbVejFv_#Ed5EK;LRu!oLHp!2H$$){$fq{Vq%r|0i08!~s&!U4Jni!!12CTtY dg+~Dx001jfF4vY4;@1EG002ovPDHLkV1n~IgH$9h001yhOjJex|NohpnRj=0RaI5)?(Q=)GtA7)5fKrp zs;Y>Hh-PMH0000)L`2=)-6A3)ySuv|9U+wf0004WQchCNtsNfE!G51fYv6fl1Z|Bq5e~ zhCr4L46X?r2UhwV{s9H@`L|33QhW+*5115q_cJg(c+a2*Qpu$NBKbbBHgJ2glrYR< vc)$;`Ao4atFW987Se>HuNq{6P)M4P`5>68+d!Q195Bh%K%D9hFv%A{oa(D!(vS$1 z9Mh*U2{16XPiLr|26DJ&wcBCbs<$y*XFI^)tHA59nxP%YpTN`bgnez$^?BsbMexscuu>R^>heqM9SAI(;$N>;%1n7*3W449A%d0A0kuwqXTB z14wmJ!WWJP9f)c+HGYRSkZR`bg$6dI44n}P3~e(Q1O)}RRYfX*UBa?~#~=gd5^sjf z5V!a-Fc~l~IRK>zWyMayvvZ zYzyFSsCr?*Jz)#WN|3}3%?2D10R;uf9M)j`idl$EJP^P{isDf)WB>qu8BK=gU2a;x1(D zqGad?h<~6JL5iDBegn@X0I{QdSJ<7_(1vKY_Quy)SSPpN%dC`NJe0j7C@OV$29$JbUm(I&pO32K;gBf7q za{SVxB~s=-Q_p6^V4J`N4I)tJ^HO!2u$tBGtcYG!RuL#aky6!7VZS5M!crP%(Unw< zal$$UWM32RpyHW~!)8i!9;7y{>5wycpcHV*O@Qlru6S^!x+VYAXx|-*gC{wt;M!DN zkuZmm!p@Z*&i^#x-;`OEcis8UH;@+nVfn%s)?I7eZ$R&=^%KhwGpAUK8F!?cUgI2F zcnrQ{WJi$eMfsZLud}Uwll@;(Z%SV4x*nK8RgB2fJ_wcHyg7MVSN`nA@iVaT$=KS?zWh zBFuJx!B>IT!B?RN$eF;?@Pt7XB+SvkaGZgs;W&dakmJA?z`zg+66OtH5n|v^5rXJd zgqf|#%=&;KUiATlSHoby*$iUDaI!pLI1a>`KzlZSU;qOFAZB5JflUo?CId5s;@|Xv;R6GHpdi2j)aU?G z4H4iXpaG%_iEVIz|G@-?gaaVgG)P>~_`Un!G$vvU!3}sfV7H6q!VQ7>7Z^JK0NG3o z3Y&oLW@KPxVBo&ba2hDY$NPzaf%SqC%Mb3|jUPCW%;2QVJ(Pg2*o6bJigFY%n+a diff --git a/docs/html/img77.png b/docs/html/img77.png index 650cef038e8ae6a036b12d2bfd68e2438bb9b9a8..8cb5d7f9b2ccac3f67d026d7406504ea149e4b8e 100644 GIT binary patch literal 330 zcmeAS@N?(olHy`uVBq!ia0vp^20+Zu!VDw>7y{3L1Oj|QT>t<74`jZ3_wMf9yJyav zxp(j0?%lgrty(p6=FGCPvW||9kdP2(XJ;cLBSl3;0Re%3b)9BF4U8p0e!&b5&u*jv zIVU__9780gCMPVgOR(c`y5Ybp;dqc)rE_Ki3uBJ>1eJA-f-D7o3=^lxvYs&xGvG8} z5Io(Z>QMJ{&s;7Z9-ZkH{6Dll?2=DNus`r%^#RUD#!N>gE2L)d`WbvUGl#+G0qf}$ z0ekV3NsF17y9Jo*bD5a)nYtsSI`|7+`6pHR2Y?GU;qKuQbsV%u=2`vAj!kPz{bG9k>KdV?!bTqK0qi= z79er#z=aDO3|N3c1BeU&Vg){i9SjQf4jUL0uqi|V9}a*>Fu}mVU;v_k=1kCHab>s= zpzvTn0|Ore6aOU+27TTSTp$dLO)U9q=>Px# M07*qoM6N<$g7UYPdjJ3c diff --git a/docs/html/img78.png b/docs/html/img78.png index c3fd2d55f938f626fca0e4773cd6af70e59006c3..9e8ee56773054b52595a454aadca2b4ca0b6f6c2 100644 GIT binary patch literal 277 zcmeAS@N?(olHy`uVBq!ia0vp^NW%MXCn)9GIfs0{Ngfm}3gG+?OJSNKo!9KQm zEE~)iXE4^V^>8W7`paN^m}i4$9nVGut=X#^n|-f0h-NtPIJ0}Cl>NHo$#aiKMu~^V z>fw0@r88VQJUpklB%CB9c;?t0l-;V+n8?Jund3&0L;_zzLe{*-cQv7`Ud#y%3=ENa WlDtRswflh1WAJqKb6Mw<&;$TDQ(R^M literal 301 zcmeAS@N?(olHy`uVBq!ia0vp^ia;#K!py+HsQxf&6OdyN;1lBd|NsA)GiR2UmxqRi zzI*r1*x2~YnKOcdf~!`o>gec5OG^VPba8RHd-txAlG5(oyX9pSrvil-OM?7@862M7 z0LicRba4#Pn3$Zvz{sbNmg2ysqhS*#k!&uI<1pz#X2OlL7mg$_1nGTX^kiBxfl>Pb zn_!Pm!Z$93umkIQOb(n3VNlWE!C=^tz2LxseF<(1%7@uDBnvnEo6Qh*{E$JX%j9xr z#+`b}Gxxs4oNvWbZ2X=Pn-tTS1`{7f>yt-;-s%|`-%Pr4Z0MEw53u(s2l?-4Ze*Me`q?>x9&(|JM1A4>yMiJ+ zBRKuMLrWc>N2LeHr+~hfrrHB~Pd;xmwKhF$2QZ5^GK6yhbD#10eh&XV) zzzjO=ZU@DBcR6xp$1KyuJ9r4j3g+a{HT^1Z8NbSv8mn|w&|ltS>$FjiKAgp5_Jay6`|2GztOQb}IfIqZXO zAy?_NBW6dSZ^hWGCWh{nwcLsx;29E^W>K_p3bZ8R%oJubc7`cl1%6QS9(yrV2jTM# zbk%Y_*oAfgn#f3M<0sn+V5}T5dzBVO=(A#2LyGXhGrI@J#g~41wACz`%YC^jhP)?e zAxE=A(^vdwmdw6ct(Kc+JDh_|L7bPAJTtuLgf|-~x@Mpi0hpZ0)CX^?1Ta>Pm~D7w zSutYP7b&`d*?r=xzf#=YVm7-K4vvYTZSo4uPg>A^!;(dlwlsUnBSub`Eu4ItDc%Qu zRPuUHN6i*!y&bw_UPJ)7pXHSmTZXyl!=!SISyqggWf4Abz2Y|RvNZ>fqq`b0J1SOY z8htR9#Z4mOL!r=v-^r-qne8uY4x8l{REH&N=(n;fN}jvDCdS=nA=)q4Y2g~~QUSE` zo~`fYGpjkKP5Xrhlgdq0$Sf2{{j&rVciUZzySYs;N$bcxMd z{31!`;c?oRA35Nv0K8uD5JTf9K4NNfW>1A-rBX>MD<~2gUNir+jZY6tMP-s}Vi7)2 zy%b;5-YInMM>Iz0y#*AY!M&RXM#2|Wpr1V@d@>0AUHI`2v`Sn zNusfu2b0PQN)4}$@MKd&3~P;ci5#svwOK>H-UcZ{{9T*@CSw6`;-_TflK{!6^(M{O zKPturH#(%98+h4@r793r-wO{+#R9U4e~NY_0g_ScO%ARz*BV;YT4z=~xOeW}6yZM` z@pok!Y5XrEZOgRHOxrTyNZT?u&X=}j(zZ<6mPy+(X%JZ43ZAfUZ#(q+REttI$qR6ed& zsBH+MMj-Wf6e)s!)gKi?{b6>65Uonrg!c!m6_uCTsIyThAU9fnpo%I#qqgD$lgL7V z`cpK!+D0i`WX`$s@XUDpSd{QO$=;cJ<~;5>_uO;Ni~**Dga5fMz+;@_)XUGH9~Ypp z19<2*Kowxi00tT&nSd9+7s^L??zmC`B;){SNjlxo(s24N2!-^#nf&Vjt2UTVb#lyW zDj|GZ*l@oKCTs;Xo!}amR!YqgEE;O#D)==0WH<}%8{Zkp&V<+lqddANoidu`#`Ln0 z2~dUsxOlxzs-{n#5?|^u-~shTibykZc1U&RkM^qGjU{EeIDNlo8>^XSpcC zIk=AVG&5Idn?2~73U4|~3o*{lgGgc27E7R8LM)eXPu~XbDx#3rWO8AEL>{}yd{fSHGNGc|o>Kw1 zLDCI$jfoGt^xOl(QE|atP3^A%&ig~voEE`xkcqfZ&oW~i% zP)t_S8W~w;xAkf$!Vww+i4NB!d#F z1_DF+tw@K5beInmRIL(2CRA2LL7a<`+A>HbmK&f6Op!gIcxi03m0F1_u$9_&kKtZu z)xa&b!vJ?ppoxbucXMP6IrIuL6(y04z_=dXJ#stY770s-V-Ac%M!f6O=sQ!T-D{W; zQjILKc|t0au1sfRU=?^2Qa3CA2)Qldz|`Vs>PZX#433Et7Gxk!1Mdww$6xU0hQ$0+ z{*fWAWTNEA7~V+}nK<2*MQ+&cyLH0suXNqU|dNE%8u&Z z1Lj56I-hB&ax7}OlM2PLERzE+VJTDV0EpU2JQ<3s5l&$^WG|6dw3DG)>OjqrD{1ae zdL2`SYNhCbvbF{lPL@!k<4^{bl!6-?CE7DqkZ*C}4Rjd$y?;*gXeram`2wAH;kR8% zEi#4~T3M^L(@kIqH9J0|hW9v~l7fkCAVD)e!9F^GournIHcT|6W2fCsBhrvd%(PkL z|Ci7h1zSIc4!58Kl!5_XjPvx;Ldt1`FMy2^#+;myr9^mRg!sFYF4S_i>{2ICn_rZV z3x0rikAK&^tz8Ay#sj-&;{m#4aeQsk@8IHFQ5fD)LHLn{V7dwHYb6gW5NJVjVmg1^ z$N73d@JiFPk*V(bE!@aj=NEoQ>a=wKTvx$Q7pl2()T!7U`K9S##FuK}6fb#4MgUX?%)9=^n$QTrT+LSt!<)q{zlT){x#LRQtr-q-HL%_W( z^9Zlw7Cb*jVmy$|dO{@UpAN3M8~(MtH%aLSvpdW<{9!f;z$1$g-H79@>*eRuH`6qdFG@a-+BP=%e- z7r`8^fVNi0DqVjHv&0Ya+4D})fHAw^;3V`1XR}~w3)cs5HD-P<}xnrY* zy38h6-A5AkjZ^TYVKXArwtt!+G9LirliS|{cSGsMt?H{mf{ zrSeWV3>%2+$JQ@sK09IB~t4bI1mEu2Vwo^!~YXK8>;g1%b+HJ~=~+Ywo%&6A&o;>IeC zDPuz=&*DrSycXmxuV5*7=b(+@;KEv17GZZ&K>i2&63RZh=<4wtZcbRG7j@i+7hEQF_eahF2V2CZIC5U}tK zL|ff|xdyDh0%y11tH@BjlUv_8O;0}`P?>AOSUYoa8P^?XjOjSQwJ9b3@Bw4#i{Z^%56&VLG$haLY-4ZwmoG*FB4B>?Fx>yf4yvFi zFdIJu-v{`yF@Th@*WtsEmj-rFGUq4ss{Ab0)7q_o>Z@3{bWy@W++GRl?4PxPdbmzM zmR*Out@v)aBE2|f!z#Xw6x*2utfo2ig7Y+d0$m!C>4RHIF{r5O75#OuM?cR6@aBa; z2@QceTK)!XEM;_1+|xexD~nM6Cb2g5X1V2~SO>*-hFb zY@u;yg~F(l`ZDwx6s7QuE%ng#ibwUvr-C({#l{B(lx@YgVf>XY!AvP-ZTKDJMWGfa z&_(b(Z`01=izxgS7Z;Lo@4V`Rex6~huQ92^SE2@Z;vA^ncoK{sgk>l-GYEa4w;mLH zt}~HhYQa}9UsEyld)_o13lqQ6Q7@Q+bHjJ6$)fOmR$CfkdpQYa{vKe=XY8~Rmz(ko bo4bDksZCi=<1hS#00000NkvXXu0mjfKtiG0 diff --git a/docs/html/img8.png b/docs/html/img8.png index d7424dc1e6e7b1be704d0810d1c77cd23d9a6cf2..7a72f72131aa6815a7514bbe4d61c56db89c28cd 100644 GIT binary patch delta 207 zcmV;=05JdO0p0~00{{R3J9s!Z0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HTuDSh zR0x@4V89Cun1aA`-lU%Q0U(CqECu}r5X12k1D^wkkyyag21r)Z&$`wC%s8dd_YKVW z#=!IzM6(D1WkC$i4GaujAO_De2Ifs5hV8-~oeCg^5lbkD0syM;6RGXx4Z#2a002ov JPDHLkV1kv(QgHwP delta 216 zcmV;}04M+60p|gb7k>@}0{{R4b)#!a0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*HWl2Oq zR0x@4U|`^6U|=}F!2gMX$pOe>;QYYAyMcj4fdK-V7=gqFeo+Qwu$3Jo29j8Dkb!}X z0m$W>FabqL@)W&&2_VMpG6vQUAcngCQm_C+1p|XQ*rEjt43j_%A-(PEffN9`RT9o( SJhGMm0000kd7 diff --git a/docs/html/img80.png b/docs/html/img80.png index 5a0d1ca4479d6291cdfd2724c9f8d4233bb7a698..c74aea15ca4ce3b996e5d35ac8c2266b62a28aa0 100644 GIT binary patch delta 260 zcmV+f0sH>-0+Rxe7k?cH00000C@`hs00002bW%=J0RLN&BDDYj0L)25K~zYI?UT(7 z!ypWWGXg7Q1y=A1tk4xagI8b$4qd=2umUTvf=l>`s!9Y>_0R+F@(748_OsaJXWABO ztZ2umeFnq?FhsGQs|v>`#M>x(Fj%3~O@jtg?B!Q`Zn9dA z%69AOplVct#OO{FV44{qqgH4uDzx3`->tPbt3P|r3$;)S^}Sxm@cwgcvC;DY0000< KMNUMnLSTY*6mw4i delta 359 zcmV-t0hs=i0`&rr7k?fI0{{R4%N9s90000pP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0z`($&s;Y>Hh-PMH0000)L`2=)-6A3)ySuxWH7^|i0004WQchC<$oq*0z?mlu@I;Sq)1R{ zekK~1Ka;82Kd$a<%`IIC5iwZ=jRD9qU*ed$3=VlOudPH|>)-KeVf3>W72}}RXQD0P ze$!rtL=$-*v^{D8VKg%98j>H;akYrK^!F%C!FzQi_kR8-VdEx$=nj36;ZVV$)9QY< z1jlS`$DW@M3PKgc6L6=O6G%Pdn~6SbwOXAAR48D z1!-*7R>Lgt5Qbi*2yw|=nf>O@KL8n>mH6j0biE&4+yGcR3-)drSP%dJ002ovPDHLk FV1g9KpC14K diff --git a/docs/html/img81.png b/docs/html/img81.png index 6619889af70f094701afe63977363ddf4e29e57e..87865247e83ee58db5447ec843e2ecbdb0b2f5c1 100644 GIT binary patch literal 429 zcmV;e0aE^nP)F4i0aF1rbh6Gl0A(?+KvTwtO9EXd2yj3-%&QF0 z)WzbGK+}oLVeP_D+<{91w=t|c6u`V$k<|>$?bAUx<8>3VM0iF4Lsxm00$yW!Ay%?k z9GJu4tHA33!a^t#mslULS{!0ufUc7z6bJ%PUBk)^4E^H_JPknHdI42}?EsMAJOI;& z)ffiW4zRWS1`I4h4E!lToY8g!lpVJz$7e1!A292NVf@V<5p- zfT)mC_Xlz^-VVf_5eXp76RChAVUx?@I=!X!Jh<-`Pm{BkaMlJvV Xeb!=VS}Cfm00000NkvXXu0mjfKE0zv literal 539 zcmV+$0_6RPP)ZgKpw7+iJK+C0jP@iC^j>Q2N=%UK!RoMw(LwDbNNH3!ofOgmR%vf&-6X2~5ld zsKfzD4L6($08+C#Qd}0eC@`=B*^C=D dWdadk0|0fDyK1(&+^YZp002ovPDHLkV1nG6$Rq#& diff --git a/docs/html/img82.png b/docs/html/img82.png index 44cbaea8f64168b21eed31eebc65797d5587e2e9..d3e98274c9d36e6f03db8d38346f9fd419d651ab 100644 GIT binary patch delta 137 zcmZ3^ID>J5c)ctOGXn#I)0B-BKuRvaC&cyt|Nrmay*qQ}%4=z11p6aXI`>;7_C`SFr%mO o0E2Y<1jaLh!4u~gEMZ`%Rc8Otf8s+jP!EHrtDnm{C#HlZ00L4n=>Px# delta 152 zcmbQixSVl1H;Sb9D?jEcRTk3&13L%^>bP0l+XkK DE@CvY diff --git a/docs/html/img83.png b/docs/html/img83.png index 2f1e81d34fe3199e8948fd35c3c87a2d6ba2a515..26f776652e2aa227ac1ca58f9cd7cf3eca5eb4ee 100644 GIT binary patch literal 724 zcmV;_0xSKAP)WaNm9l$n-_mG~zQ~4$~y_&$I_9psldlP-Oy@@{C-b9~mZ=#=D%wL%uiW1HK z|C2@9pHKKWFN5hBETYl>BRcce41jk#;jd5z2Bbt`IQI8Ot~VFlbb34D&r}A+ixPFi zu@7yOo1qzjVHD2fkNEim8G4=y+gJt+SbL0Zlmjj)`m^o{FRL)b5I5HZ7*|Os%nSU~ zhV5IBD2A0}$&y;GA)xqG{6+v>h+8BM_zq4Km#l}b87VdoWflb9HqC>8E?gA8 zx@s3qm=pKLRtG6{84tctjq)P9a@Zu=2&}R^^ib^hCBRgZ<8@HJYM*-u(srdQ00KSn_F&gjez29^|a&5-X@bsvW?$j?GH)4m&}l8 zbd%%eYMt@fC7Px__m+2}i?lR1i8ca16wie#z7Un?Yz~EPOm~L~N?Ni8e$#2Xo@K~| zXKJog<0QfGQ9@!3b+}aL#2Q1%Jgmj=JAq${H|<5y@GbQuvZ*Ub^sVQ%BT=7y)f z7M6%ordqVe3R>?Y3Pf7;)wQfKqKoqG)zzAUb*M?S9Zz{dl;BnTPC(8NC3c4|i^;jg z7AKRY7RfKootM&8E9evI!!x2a8iJ(u-~n-nOl}OcvUbhBE?15nPfLz+pI0E z7tsfq`SbsOKbiS|etF3);#{Jm4oB$fDQ8)sm!r6c;BUj_nP(^k} zHY-Ow1UY*R5mtk{BvLVW88N16ZXOzNyo4MaOuwr6`2p0AnvP>|vtF8De9BvJwB-Sv zKk!lOgV7_iJ{cJgw+9pAVAG+T1tsKtq{P;_IS-QS>NfR=vPGPUuiJzeIbm0OU$7F5 zp3~GfvXg%S=91X=@;FiTvoN<&wrEtQ5mHN{o9;%k`DKgPa3$@v33ib$ib5k(|M7U! z*A0eKDlBSA+T|d!Q$Ht?=ke#0sDbqJK+VE&)PV4`Q9MuPg`!GK&}1a_g_CFT|q!d(Z#)J3*eTmw6@}r3+%z z_r_|u!EcS1$Ve<9UZMwBccC<*xe|`sd%T)R2O!&aV&A;z^d~3tW09pC`;_OK@@N(1 z$z9~$@XHegl&hu17vF5H1bMhki6i*(gN0I;&p&et#6nA>ip@8{-g3(w{!H0%(1$a4 ziql#{@v#HCg`8P#p7$YI@@}NegCT#AX522H_u^wsHNfFkC&Dc>--vC=@gHhG&Klgm z#Zp7;v!dDWgsWzULGR-SMvH>4B27DdaUeGXrLYN^!n`^=`{?SmuOMN(xD_2*ypBul zFH(K_3htIjm1PQToZ|*!@{@Unyd(HVeFPmovI)P;!I`8SC18&~{pcO~}0000@}0{{R3eRWAK0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*H(@8`@ zR2Y?GV4yj807h5=>je2nlFpCNQ^`F?f_MVC&nV)_=D{!K2cFbLsRAAh}KK z8+;XdST3`LB9==G4aq&62S9Q!f)$Q481ofyE?|gd03yBu4}*a15HoXSRfHHA z92K|=7&;h$$T2j4f#EY)id{i36zJ|a27VKUV=O=v2oz+2_{86VTjc?RrVm3LJA)7i zDKaok0GbbWcR=VghR(18uC&@ThNF{!h<$201JHahFkxU|a$sO^VlZG}VE`c&1_ox3 Z1OUNoF_3d8puqqD002ovPDHLkV1l!xc~$@b delta 355 zcmV-p0i6ET0`UTn7k>>10{{R4Nfzc50000pP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0z`($&s;Y>Hh-PMH0000)L`2=)-6A3)ySuxWH7^|i0004WQchCS(=jLs68$nvTJEIOvZ6N1JFKZHPqTiyIA#=&wL*^ zIHHb>FZ2CycpfziqgFKP)jfH6oRZMilxffHZj;1qYxWJpA;HUvAt>yK~R|&iTIi=I-4Iu&HrybK7ksZvV#}^0AqD1sJY1fwEWE-!SJk zTD7ljL8M3eBX@1aN=SXmUmM*rL@bk~;~hL&sx`yCgf=-Is5xCiL`1?67$7W2qB*&A)C(7>P{vu-cb0S)ZQXh#j2Q@Qdo>uK%MQ z$$-#~f(_%-F&pO0S!i}V`PHlsV`9j~@N=^&C9}R~j{$>^SCRX63V30~N9L1RhR*>R zuFjl2|0cKESs`G(Hut{!o*$LKM1qih6h{_1K8uO$J@b@{J%@etmgkj94rY$Fq3`|3 zg)txI2QMQ%8GyoDm{U0(L~f+;YGvxdaYrP}>K3D1u-cISBPW~opiq#t{|Y?We&1>EKu ztC+_dctEM-5avj*=4C9)#dbTr7~>#Kl9NH(9V1ScZ~3CZQ)G05J`NybBkOd!x*av# zS2BNbZAzzaR4JNedvHJS1l>hw$J?-cRcP_8r`!~;3mo90h*TI8;ss-3}C7t0o#eMJA8)l!%=hZea%@#&2;r zeY48Z%o4!viHIGi%jHtUj*jX$uMx1|M`};U)ev3~R!C^Yo-D7XT?Z}^bom=I}_iCfoc*WQ45QOxT=$(rJvcIX_!N27vmCBGg!H&0ppLIJV zCj-lEvO_d@icG#NU9M5Zqv$T{b}W*qmTR2DFmG!Pnf-_@FnjQ)3(sUb%5-*62Pu@J zw8IuM<9F<`Belk5=~_31&kjLwKM8-^D1Yp)-}n#e?AStY1AR&*mkDzN6|7_Q>p^L-d1l zaq#3cwjCzXm#68Mg)WA!^FhcDGhe*b=T>_v^cEtu#bPn{E575i)Ve8X&qRXYegwda zi=EQqB_}}auDtdRL8dWv=!8;9FvZ+JDb3bjuKD3{5;Eq*IZ7%g1IvvSzB+$&g*9*w zAwz)#q*=rc=wa6Ah%?e$9h_ppY=Hjc0&e<)ijV*OI}M1eo3DMo=-+plb2K^ze}$h)sCZW z;Y9M%&`Mi9ts~EGx=-J8ED?}i^F{OSbrH2gwdH7A=&y@=1HtFR9eX#s>wgsV5B}e> W0%^&FfFcF}0000GP)RG%l!+koHajol;;UDylfwP=sP)MbQxpu~j6x)kQ)yAcKT-qCk5Gh#ZZ1 zZ)V5#?%I1xM8orWcjnFe`R1E9<2iuSh0|X>0*5-TR2@Mi22eM`&s6NCQ8a)$2WP~= zvSd&&-~Jxq z)KWea)bE=O<BQ1zjyf0}jl$syNoD0M~J}iOp#YUpFY`4=nClz+9L4eM}Xq zELafaDCJlO9|Oj{?zrpgmLbykSj23KqYeTGzJdV{;eDXB!qKV-S1Jh{`gZ_*g#%FG zjb$NXf`A1sHPKm=w1`ZO@j@UDmpuni6MD{L96^Gw`^)%76xvZj5iK<>W|LSNFbhNz zvaqWDI|)@|R(?e$DkWQ#UPdFPo!!C-DMKk2Ms*s1QRj3R1*MZ#7`Q1Kp@PwAW7^Oq ze1?goEKHgMo#AlV!y+`mb7y-4w}xNGf`f4!&Gk$JeSQSAh}uK==?FOzu!7g1W3iK{h*b3l2g_5FATwnOGv6Vo8iHzO}KKA5_ z=x>I9#lirrx+8;fiTn{vTi@biK^d!cXmoPXa=SGB&U(bdTB`s1XRa9JE#A4b~7Sq!$KGR{KSG#R~xTWqJrBvgPmV#k&H2g8G5lQ3WmN`@&JER%nA zgeeKc-J`VJ;PgAKUno)DO|_gimLrDy&a!yMFE6nb3hWD4aDlW^&Epxya`BR9SjVS zXK-ujK;}erG{eMth|{87j1VKJg}nkqZbA}6(=sbOqh#6!28Pbc1gMr!ACSHTsQgL{ zEo>H-Sf4Q*W#CTWEr4nX08!kbp`k%Q+G7ER7FO;8whIhT80r}K4H$H$fWx(2PT?+1~BIMz`(GbA(nwBlEJ!M7#=SUV6x)O zVVEswz<_}XtO)2IY|>c8z<{lQqXE10EL>W+n?PPajzxx}4VRu!1EA|C;F28$qW~8G Y01L55mjP;vk^lez07*qoM6N<$g8$y7HUIzs literal 502 zcmVHoSo3_yNyS;espx~4-T@s}p2oDA zp`V1Vu+C9{y1k`|D&JzwGI12l)Bzm*WemC`Xv4Hi!c|Tqr{1(l8nfZLEBC{mWGenX zOhfo!A%egW`!V6PTAgkc$Kq9nkj+Gf-WrGJKZPHvswg;V@Py5hiMJuc3SzUIg!3t$ z)48RrAKS&-;FUD(Yv#Mgkn3C@6Jd}Dr5S9eJGyRj=m#5N#2DTSQM03T)ygn*!`8U& z;ssa0MMy<=LRQpWn46ty4^0#{dyhB*zGT~Pl9%3es!?MXC~@E{QUe^K@PqAk3yI${ seYHH4Jk!Zdzi-W>5N@3RvMbEu4`Kd9_iPEVw*UYD07*qoM6N<$f|$SKNdN!< diff --git a/docs/html/img87.png b/docs/html/img87.png index d280160a6ff8a74211c90e54066367fd400fa936..75d638457fb86dff4ffc95d1a6348553b43953af 100644 GIT binary patch literal 333 zcmeAS@N?(olHy`uVBq!ia0vp^YCtT{!VDxU(-!>zQU(D&A+G=b{|7SPy?b}}?%gwI z&g|a3d)2B{GiS~$D=X{h=txaX4G9Txc6K&0GE!7j6c7+dda1q(sDZI0$S;_|;n|He zAm_BFi(`n!#N>npvL0+nej$qA7}(6%pRtJ;ahOj+iPDEludx9Igi|~n*qt?gGq;_W;Z;y$*1qxRI1lR` z-ZlIUNj&oxCh71?sC`f=&`HQnNZ9>=;o|A4hN}(Mj_VmR*vkW%j_|c5XY!o6&CT18 z_izShNjIZM59<>pd$u-J9v(g(9xH?A%Zy7J{<5(Y?0`6pHR49?HkUee!F%X5n{n27z1Ka>3(WF6J=0h8TLi3Z{P4Vm zzV@_6#L6i?E73yu*;A>r1l9HBN0os3gU;2ZeidT0si}k}2&1(uV;VM78CjMgZC^IB zYR}VSlgi=2F|l_&#ck`{fH!zye4a}Rf4utGFP6lEgG_TiGx&13Zf7nS5%sLGZAI;G z#+G-!-7Q@x?;m#ioXKuO*dsc?`ZOcRnpW+}tI6~6f&0(ly^a1GKOG|}7$Hr9wEzGB M07*qoM6N<$f~td|0RR91 diff --git a/docs/html/img88.png b/docs/html/img88.png index 89a30141f4e44021229186d55eba774c3587d7cd..3aad7e2996131cc7de8b940512046da303e0472d 100644 GIT binary patch delta 218 zcmV<0044u`0_g#e7k?cD0{{R3Sg29<0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*HXGugs zR2Y?GV4xLXuVDDfz%hLqkQwU3u$*BV!*w7tpo1Zl{Q<*gkW-4s3 delta 241 zcmVxG>{4kl}KhpySLy+)Z1_AB{{s$nY rEF<>KYE9(xiff0}PBn1UbSk~%$YOG%E~%AI#N?pLqbBFot=%0j1(0W1q1|=UaIc`YG5o0@(X5gcy=QV z$Vu^ZaSY*@nVg^?6)`t0;QuRF?hQAxvXd-XuCO>hw#nNJv!d zIJhb9y-0%!yR^rmhRN(pre-p&syeoUmq$mz*n)e8nSlX!18XI>gv&vmzP(;vuNAni m8x-U;>{!;=c>6#fBZI!o$w6yEqoas;>WKq9L5H3m*v8+q@O1TaS?83{1OS6GK2QJv delta 171 zcmV;c096090lEQ@7k>=|0{{R47yzQ@0000UP)t-s|NsA)nVENYckb@)5fKrps;U40 z0Nvf)A|fKYySv!IzG%>Ywu0-VKskb$9;fk7Qb8YpOi;N>tdH!wt= zK{X+Vfg=FU>0sb+U|{G$Rnft~v;oe!%D~Hjq2ek7!yypOUcvB{Nr1rzrh*-$Z&r9l z0Z@>k4I~ok!?2v~07C?_3O0*NtPg;K3^PC?0UZpX91TEAk!)e*E?_$V6a?#IV0g?> zz#D+7f`Q+FqX8%gQNi+nVS*wvLk5ZpKL&ndpdiE+)&r~tF`NjOvNnKR$`H#56oj~x z;aD1jO)1E?5%=4HT#gSwVmpIPDo~K&FjxhP0t1r)1D6AGP#7>UDF6kT4j_p!H!xrV qq)-QfsaRB4pzt{G#{MXvF8}}z@HKcMdLsJ(0000*Qn60MFc5u7TDNIh$ljqYYlW!z0&lE{iP0nKl&Lcd zE6OJnsUKjmbwG4t?t~Cu;lRkk8QTd_J2Wg6Pm1sE<@ug3G2jtm4+LgmB;HH?3n5p| zLn*}P2_@3-gNA*81Y+V+wV~xgh=fRR43ic*#AJNcw~QEk<$Wj4%MOdio=u^B61y1D zVQTI?@O6k3=;}-LQ>Az{M<=Yc-@~S+?nISDR#~ZFUbwyi7 zsU#AasfrJY2aPds@_6c8KG7=-8C3U;e!ti;<9n?dZ3|+#W7j{%H^AgMgfU{iXaE2J M07*qoM6N<$f;^nE!vFvP diff --git a/docs/html/img92.png b/docs/html/img92.png index 7a1571bee715c24a2bc9cbc0d98ab1ce0dcc993e..7c89824f5aa895e2335c77175bb331db87507623 100644 GIT binary patch delta 466 zcmV;@0WJRf1K$IX7k?iF0{{R3f-zSo0000mP)t-s|Ns90008dp?%mzp%*@QYySu8Y zs+pOYc6N4%h=^rnWmHsDLqkI{GBP0{ArKG{V(BNk00001bW%=J06^y0W&i*IT}ebi zR5*=eU>J%Z8B>T8Ofny2U`PSd*1}*edjJDd0g5sk0pv~FFtE-! zfTED?07EO7(E&Ao0hnrGVBkPi$kD){4Q5=0@VOxtUcgYu8^FM$0Hm1&7|I(MSlaUq zG^^bXvmAgbWZwWJW`$=IFem~=62MMi4LQKztB}Vqfv4dKYXg!(Hj7KF4?uq4Yydlf z73hlR46_&<_B2;D6#E#13u+^%oS!E*|be zCg&gyf=ednQczJS^>R%ULNXL|5d7f1ckjD*_wL?%K!Q!7$H>FwvM*K^3Xnrk#-ME( z#l154v2wV0DfQ?scXSzyYXFU(#pb?FxaxhVs-(FL3^JsM+311bjO-mpejrGKryT_8 zEmFFw|K8JrDkL{63$P4_D5lD0~g$`4~0u8l>A7(1S)bH_}i}XfWIK^#A|>07*qoM6N<$f}s%OP5=M^ diff --git a/docs/html/img93.png b/docs/html/img93.png index 79cf58a608ac4cb053e96d889a83c89e734a4a70..69717c634efe885a1b6350c2f88cedce10028b18 100644 GIT binary patch literal 211 zcmeAS@N?(olHy`uVBq!ia0vp^f?A+G=b{|7SPy?b}}?%gwI z&g|a3d)2B{GiS~$D=X{h=txaXb#`_(GBQ$BR1^>pn7v^e4^TB@NswPKgTu2MX+Tbh zr;B3<$IRpe1)dq^hi2X^2xFg9D&n#s+`uMPh+(7CUdd^ja~U==SxGoqN*&13GZy*4 z(jcKDE}^Dj)Eu!!I)ZnR<-tw2FG;NNKByzc%BIH5#>VjLKcCLjs0W*X<}-M@`njxg HN@xNAZVE<2 literal 219 zcmeAS@N?(olHy`uVBq!ia0vp^LO{&N!py+HxcqY>h@%_e6XN>+|NogYXO@?jzkB!2 z*x2~YnKOcdf~!`o>gec5OG^W)a&d9Fd-txAlG5(oyE!Fi2m*x|OM?7@862M70LjOA zx;Tb#%uG%I0=6W!WPyVRma#6A*dcMFL4}=J#(;4nlRy%?L*X}eKJJD!y!;ATJO-kM zYnwOzFl+GG$+?wBhuIqD%>YPDz$tBBj8(W4sL{a!rd3$#1fnBQG%@f(s6$YjI~-7T1u`&*0;%XG2)C;|OQF1hKfs59 zfxUu(p$(#G6)0#JW`$=Ia4aud1lPrJ8KQ~R;t>1NkON!=5ey8WK%Fx{f-D_iO>7pI zSRVxUC{$tC#ed3Oz)-U~+5+0=6^ELFi(LXa-C18*pvlGhk-` z>R|W`)wL3$3n<6Y02EveWEwIs3n7J}9|K>39|I>t2GB(p93U=)S?0&UZ_M(5;W?1W zdfX+rz#(%BD1jYoA7k?lG0{{R4f6Kr)0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*I#7RU! zR5*?8R6R?>P!v5$(+|_82_lG#1QF56=q?tWbaHZzlZ!(BfPWwrTsr6^9RypaB8d3| z#o{dZCc(+#F9_1b577JGGfi4s5kIybNbY_2zWdI3_azVbKsI#X05(3O0%$$L5<^3w z=j-B)24?!s{tlR6vlJx4(fEkWJcK$Ee2V)kmKZD>Vv__N+j=}@(tg&+j^;}$GMsUl zo?C2~QJvcYGk>v75sez?)pN;qx#2_fuHC-*zta2meklTc1vs1_3Yz!)Nl zrh^MhuQL^69l9o5k=+Rc=R$C$yLp@4flj1&*N(oPGr-UB4wMpJIE(2>82|tP07*qo IM6N<$f^Crm;{X5v diff --git a/docs/html/img95.png b/docs/html/img95.png index 48aa78e3f8d4cf21d250e237bfc08d657a632e96..622ea153c15e360a5c79baa23bb2c3595290488f 100644 GIT binary patch delta 260 zcmV+f0sH>H0+Rxe7k?cD0{{R3^(jeT0000jP)t-s|NsB)?(W^)-OS9)ySuxps;Zfp znRa$|h=_<~Wo1-UR6|2UGBPqDAt4YD5RDErVE_OC0d!JMQvg8b*k%9#0F+5YK~yM_ zV_+C?Acj-MV>h}8n*xkgjV{Gl<$xl^F(tK(A+3N9B+6LnfPE|#R3qTa;=F+~0nE!z zK$3D;#t_ZIUcdrX50Qh~^@yRIfmeYIYKvC^LW=nU!y^S-1`dc!RwA-9Ca@f6@MdsA zwhAi6mB6&sfjcw+ZKWG7!bYz#z!LU1)~7k?fE0{{R41iA}n0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*Hy-7qt zR49>SV1NJv210;|fq}Vzfx!VuXg3&aKvl=hz`(QDfx!VtGk>@XFoXEG09O4lU;;6V z;Q}KMh|A1?Fp0?ls}70*{{lEm0YY;wVCZH?a5n@nG6Jbj5Z;8JpwRe)YyuN)90mrv zkpPY`!v|Ob&_$FSU@Wk4EJ7E5D)4@0=mT;1jU14q`1w9C2JlXXd5_-+A;mD6VJaKL zUWOJ1WNi?sXDSTq1sH@fkR|w)HVKgK_CW=9;{qE1Q!_#16YUSl00000NkvXXu0mjf DtxN!!nMidLAQXE5gLyGQ#p(F2Lj3?&wns5a0GyvEew1HtQQEG z-^0Mbv;oYzz~IQhAVh?EhC?6*%K?T!1_n`NInJeJ?F<~t%NC)jZv!z{8!*%-_bS9O z1otRZp{bt%VsK!p57^F-10v=yFt~;S0Ze@a4)qM589G43YHaG+8W;>2m{I)8@_^y9 z0g!l(%{@T>@_#t69RTYF`UOOBE?~Vdf%5?S0c`#Sh9}D*YXb&`exTbvfGO?*=3@ce z+o}{0$|LT#GcX(mGnX(hs0N@opP7L{iGknPfB_XSLF}_&zzX~@M4;(`GXO&d2w3+` pKo^1;+>G4<41i(4C>Zeo0HFRqGtWP4Q~&?~07*qoL0#w0(@&sjJVPr?@#s*#4qJQoP#Ky)W_zjwgDT5dG zJVI0@A7)9u z+<+LX-Tz|YZ$(HW5k0B?SfqQv_{3w(sAoPA0JY!;^mSMz zDZh4n;VK=rfi+S@u`^ytodRdtO<|`_v5J>h`9is81SKYB&FbGh;Ck>*8~mqoti_iJ zF7Z}4lLjADyiLQA$!``&xJ^mc;9ceV(EXl^zf275LpAh+0lzvvF!1ToF7T*que-sd mm5E{S1B7C8U|>wZu0kC~v2<_1u7ceGOceuJI8-n$ z08`g r4%k$9-9XY@gw+rbXuv5m3TO)eWaBTv={hfR00000NkvXXu0mjfC4_z2 literal 394 zcmV;50d@X~P)0AY$QjdG6Yr2qf`07*qoM6N<$f*HDxivR!s diff --git a/docs/html/img98.png b/docs/html/img98.png index df9999c45dc7ea3e7673d9a791d4d58d363d4803..61323a77c9b9b45603d8175057c92b9c07617aad 100644 GIT binary patch delta 244 zcmVA#Im|&w>2`!)K7v&kP+5 zehl0VtPg-3mIn;i7&=&Z5;zusOj*Dr#PGz0J3+4i$m1?xy})pE0`vAl10au?fkA0000mP)t-s|NsA)nVENYcU4tY?(Xh0Gc(N0 z%n=b0s;a7ph=^upW&i*HL_|d0-Q6N0BD=f09~~i;00001bW%=J06^y0W&i*Hn@L1L zR2Y?GU|?Y22Vw;V2msLn3^2eH4P))zy?X;(xZy%5P}dJ2>wg0Sk^%+{u;IW2CO#

D%PDHLkV1npRX*~b{ diff --git a/docs/html/img99.png b/docs/html/img99.png index 33d40e54dc54ae238a7071846bb64055583ee0a9..f7967e00778c92bec19b9e9753ed471466f98ba7 100644 GIT binary patch literal 373 zcmV-*0gC>KP)JNL8IK$%gkle1U@E|+hPeSuSun89Ie^okRxsJZ zz`%i9jW(FPfL9HV0+3)ifT4zSX<55xHc)u_GzN|Ypa5$FhMMGFg}4Ns0ETT0*BLlL zj^@Br6R@2jmx0fL{Q<*guo2kQ0Hrz@{1~_!SRX*tuwklUdBAXup@W4dfnx#0F1VW` zAZ`OvoC}zQ7@oLrC+HPG+zj+PYwr(WK=%XHegIS41*{hsj!t0SUTDC;V*paK1S3qC z85k58Sbz*a1_m9lhz0h*V_--Jx*Qr8oB=r0?9gn0#VJEG4mGU7@U$@s1_=NFVnjC_ TD`xY|00000NkvXXu0mjf(I<}+ literal 415 zcmV;Q0bu@#P)T#y?J;5>x`8&Z5hi~~T-2z0Li4?RR#qH;kt zDllz876OIF1O^l#h$g7e93}^b2OHRtg;-fRc^ejRgEeme`H+c$gNM79*MWxt;%zu! zV&DamE=VFg{R|7p^~_)aEK3*|Tye^JL8v=G%#GWOSTK1WLlLjkjZgWV3Jh!-LKhhR zfQ2?-C}QJwU{YW!U^v8(2a_tmv`&e^n}J#6{uTy91_ns{&17Ksq^$^yKm`VdAPDt@ zL6d>`2ZLm109YCbm_9II2doWz2@L!S5RNBquQ4#F;FBB{002@YFn@UT8g>8x002ov JPDHLkV1j~;mXQDe diff --git a/docs/html/node100.html b/docs/html/node100.html index 0683e8bfa..7b5153cbd 100644 --- a/docs/html/node100.html +++ b/docs/html/node100.html @@ -104,7 +104,7 @@ Type: optional. Intent: in.
Specified as: an integer array. Default: use the indices $(0\dots np-1)$.

@@ -138,7 +138,7 @@ Specified as: an integer variable.
  • A call to this routine must precede any other PSBLAS call.
  • It is an error to specify a value for $np$ greater than the number of processes available in the underlying base parallel diff --git a/docs/html/node101.html b/docs/html/node101.html index 5f3bcf8bc..8893662a1 100644 --- a/docs/html/node101.html +++ b/docs/html/node101.html @@ -100,7 +100,7 @@ Specified as: an integer value. $-1 \le iam \le np-1$
    np
    @@ -124,14 +124,14 @@ Specified as: an integer variable. $0 \le iam \le np-1$ --> $0 \le iam \le np-1$;
  • If the user has requested on psb_init a number of processes less than the total available in the parallel execution environment, the remaining processes will have on return $iam=-1$; the only call involving icontxt that any such process may diff --git a/docs/html/node102.html b/docs/html/node102.html index 7b43e508e..4bf067cab 100644 --- a/docs/html/node102.html +++ b/docs/html/node102.html @@ -100,7 +100,7 @@ Specified as: a logical variable, default value: true.
    1. This routine may be called even if a previous call to psb_info has returned with $iam=-1$; indeed, it it is the only routine that may be called with argument icontxt in this diff --git a/docs/html/node104.html b/docs/html/node104.html index eb954317d..4f6640f66 100644 --- a/docs/html/node104.html +++ b/docs/html/node104.html @@ -59,7 +59,7 @@ call psb_get_rank(rank, icontxt, id)

      This subroutine returns the MPI rank of the PSBLAS process $id$

      @@ -106,7 +106,7 @@ Specified as: an integer value. $0<= root <= np-1$, default 0
      diff --git a/docs/html/node109.html b/docs/html/node109.html index 41185eb8e..0e1c196da 100644 --- a/docs/html/node109.html +++ b/docs/html/node109.html @@ -93,7 +93,7 @@ scalar, or a rank 1 or 2 array. Type, kind, rank and size must agree on all pro
      root
      Process to hold the final sum, or $-1$ to make it available on all processes. @@ -108,7 +108,7 @@ Specified as: an integer value $-1<= root <= np-1$, default -1.
      diff --git a/docs/html/node110.html b/docs/html/node110.html index 3207aa077..3aa9ae82c 100644 --- a/docs/html/node110.html +++ b/docs/html/node110.html @@ -93,7 +93,7 @@ scalar, or a rank 1 or 2 array. Type, kind, rank and size must agree on all pro
      root
      Process to hold the final maximum, or $-1$ to make it available on all processes. @@ -108,7 +108,7 @@ Specified as: an integer value $-1<= root <= np-1$, default -1.
      diff --git a/docs/html/node111.html b/docs/html/node111.html index 62ffdea7f..90ff9bc27 100644 --- a/docs/html/node111.html +++ b/docs/html/node111.html @@ -93,7 +93,7 @@ scalar, or a rank 1 or 2 array. Type, kind, rank and size must agree on all pro
      root
      Process to hold the final value, or $-1$ to make it available on all processes. @@ -108,7 +108,7 @@ Specified as: an integer value $-1<= root <= np-1$, default -1.
      diff --git a/docs/html/node112.html b/docs/html/node112.html index 7da2ac37d..b0daf245b 100644 --- a/docs/html/node112.html +++ b/docs/html/node112.html @@ -93,7 +93,7 @@ scalar, or a rank 1 or 2 array. Type, kind, rank and size must agree on all pro
      root
      Process to hold the final value, or $-1$ to make it available on all processes. @@ -108,7 +108,7 @@ Specified as: an integer value $-1<= root <= np-1$, default -1.
      diff --git a/docs/html/node113.html b/docs/html/node113.html index b3f97eb8c..29c4d4c92 100644 --- a/docs/html/node113.html +++ b/docs/html/node113.html @@ -93,7 +93,7 @@ scalar, or a rank 1 or 2 array. Type, kind, rank and size must agree on all pro
      root
      Process to hold the final value, or $-1$ to make it available on all processes. @@ -108,7 +108,7 @@ Specified as: an integer value $-1<= root <= np-1$, default -1.
      diff --git a/docs/html/node114.html b/docs/html/node114.html index 3ce8b6564..978793127 100644 --- a/docs/html/node114.html +++ b/docs/html/node114.html @@ -93,7 +93,7 @@ scalar, or a rank 1 array. Kind, rank and size must agree on all processes.
      root
      Process to hold the final value, or $-1$ to make it available on all processes. @@ -108,7 +108,7 @@ Specified as: an integer value $-1<= root <= np-1$, default -1.
      @@ -143,17 +143,17 @@ Kind, rank and size must agree on all processes. (local) NRM2 operations at the same time.
    2. Denoting by $dat_i$ the value of the variable $dat$ on process $i$, the output $res$ is equivalent to the computation of

      diff --git a/docs/html/node115.html b/docs/html/node115.html index 2c5e9efcf..3a521f91b 100644 --- a/docs/html/node115.html +++ b/docs/html/node115.html @@ -89,7 +89,7 @@ Intent: in.
      Specified as: an integer, real or complex variable, which may be a scalar, or a rank 1 or 2 array, or a character or logical scalar. Type, kind and rank must agree on sender and receiver process; if $m$ is not specified, size must agree as well. @@ -107,7 +107,7 @@ Specified as: an integer value $0<= dst <= np-1$.
      @@ -124,16 +124,16 @@ Specified as: an integer value $0<= m <= size(dat,1)$.
      When $dat$ is a rank 2 array, specifies the number of rows to be sent independently of the leading dimension $size(dat,1)$; must have the same value on sending and receiving processes. @@ -153,7 +153,7 @@ same value on sending and receiving processes.
      1. This subroutine implies a synchronization, but only between the calling process and the destination process $dst$.
        2. diff --git a/docs/html/node116.html b/docs/html/node116.html index 2dcc8325b..8b701609a 100644 --- a/docs/html/node116.html +++ b/docs/html/node116.html @@ -90,7 +90,7 @@ Specified as: an integer value $0<= src <= np-1$.
        @@ -107,16 +107,16 @@ Specified as: an integer value $0<= m <= size(dat,1)$.
        When $dat$ is a rank 2 array, specifies the number of rows to be sent independently of the leading dimension $size(dat,1)$; must have the same value on sending and receiving processes. @@ -139,7 +139,7 @@ Intent: inout.
        Specified as: an integer, real or complex variable, which may be a scalar, or a rank 1 or 2 array, or a character or logical scalar. Type, kind and rank must agree on sender and receiver process; if $m$ is not specified, size must agree as well. @@ -152,7 +152,7 @@ not specified, size must agree as well.
        1. This subroutine implies a synchronization, but only between the calling process and the source process $src$.
          2. diff --git a/docs/html/node117.html b/docs/html/node117.html index 0204f6043..a596e0c1a 100644 --- a/docs/html/node117.html +++ b/docs/html/node117.html @@ -212,7 +212,7 @@ ifstarsubroutinesubroutinepsb_errorPrints the error stack content and aborts


          \begin{lstlisting} call psb_error(icontxt) @@ -282,7 +282,7 @@ ifstarsubroutinesubroutinepsb_set_erractionSet the type of action to be <P> <BR> <IMG - WIDTH=$\vert{\cal I}_i\vert + \vert{\cal B}_i\vert$. The returned value is specific to the calling process. diff --git a/docs/html/node120.html b/docs/html/node120.html index 42b980f88..5205b0eb1 100644 --- a/docs/html/node120.html +++ b/docs/html/node120.html @@ -56,7 +56,7 @@ hb_write -- Write a sparse matrix to a file


          \begin{lstlisting} call hb_write(a, iret, iunit, filename, key, rhs, mtitle) diff --git a/docs/html/node121.html b/docs/html/node121.html index c2ac64722..5ef1126fb 100644 --- a/docs/html/node121.html +++ b/docs/html/node121.html @@ -56,7 +56,7 @@ mm_mat_read -- Read a sparse matrix from a <P> <BR> <IMG - WIDTH=Notes Legal inputs to this subroutine are interpreted depending on the $ptype$ string as follows4: @@ -124,19 +124,19 @@ Legal inputs to this subroutine are interpreted depending on the

          Diagonal scaling; each entry of the input vector is multiplied by the reciprocal of the sum of the absolute values of the coefficients in the corresponding row of matrix $A$;
          BJAC
          Precondition by a factorization of the block-diagonal of matrix $A$, where block boundaries are determined by the data allocation boundaries for each process; requires no communication. Only the incomplete factorization $ILU(0)$ is currently implemented. diff --git a/docs/html/node129.html b/docs/html/node129.html index 93dd2c962..19caf8bf4 100644 --- a/docs/html/node129.html +++ b/docs/html/node129.html @@ -96,11 +96,11 @@ Type: optional Intent: in.
          Specified as: an integer number between 0 and $np-1$, in which case the specified process will print the description, or $-1$, in which case all processes will print. Default: 0. diff --git a/docs/html/node13.html b/docs/html/node13.html index 0fdc4242b..bb1a1de5a 100644 --- a/docs/html/node13.html +++ b/docs/html/node13.html @@ -85,7 +85,7 @@ Scope: local. $|{\cal I}_i| + |{\cal B}_i| +|{\cal H}_i|$ --> $\vert{\cal I}_i\vert + \vert{\cal B}_i\vert +\vert{\cal H}_i\vert$. The returned value is specific to the calling process. diff --git a/docs/html/node133.html b/docs/html/node133.html index efdf890f0..d6d5a993d 100644 --- a/docs/html/node133.html +++ b/docs/html/node133.html @@ -72,7 +72,7 @@ err = \frac{\|r_i\|}{(\|A\|\|x_i\|+\|b\|)} < eps --> \begin{displaymath}err = \frac{\Vert r_i\Vert}{(\Vert A\Vert\Vert x_i\Vert+\Vert b\Vert)} < eps \end{displaymath} @@ -110,7 +110,7 @@ err = \frac{\|r_i\|}{\|r_0\|_2} < eps --> \begin{displaymath}err = \frac{\Vert r_i\Vert}{\Vert r_0\Vert _2} < eps \end{displaymath} @@ -120,14 +120,14 @@ err = \frac{\|r_i\|}{\|r_0\|_2} < eps The behaviour is controlled by the istop argument (see later). In the above formulae, $x_i$ is the tentative solution and $r_i=b-Ax_i$ the corresponding residual at the $i$-th iteration. @@ -194,7 +194,7 @@ call psb_krylov(method,a,prec,b,x,eps,desc_a,info,&
          a
          the local portion of global sparse matrix $A$.
          @@ -271,22 +271,22 @@ Type: optional Intent: in.
          Default: $itmax = 1000$.
          Specified as: an integer variable $itmax \ge 1$.
          itrace
          If $>0$ print out an informational message about convergence every $itrace$ iterations.
          @@ -306,7 +306,7 @@ Type: optional. Intent: in.
          Values: $irst>0$. This is employed for the BiCGSTABL or RGMRES methods, otherwise it is ignored. @@ -363,11 +363,11 @@ Returned as: a real number.
          cond
          An estimate of the condition number of matrix $A$; only available with the $CG$ method on real data.
          diff --git a/docs/html/node134.html b/docs/html/node134.html new file mode 100644 index 000000000..fa6197a58 --- /dev/null +++ b/docs/html/node134.html @@ -0,0 +1,180 @@ + + + + + +Bibliography + + + + + + + + + + + + + + + + + + +
          + +next + +up + +previous + +contents +
          + Next: About this document ... + Up: userhtml + Previous: psb_krylov Krylov +   Contents +

          + + +

          +Bibliography +

          1 +
          + D. Barbieri, V. Cardellini, S. Filippone and D. Rouson +Design Patterns for Scientific Computations on Sparse Matrices, + HPSS 2011, Algorithms and Programming Tools for Next-Generation High-Performance Scientific Software, Bordeaux, Sep. 2011 + +

          +

          2 +
          +G. Bella, S. Filippone, A. De Maio and M. Testa, +A Simulation Model for Forest Fires, +in J. Dongarra, K. Madsen, J. Wasniewski, editors, +Proceedings of PARA 04 Workshop on State of the Art +in Scientific Computing, pp. 546-553, Lecture Notes in Computer Science, +Springer, 2005. +

          3 +
          A. Buttari, D. di Serafino, P. D'Ambra, S. Filippone,
          +2LEV-D2P4: a package of high-performance preconditioners,
          +Applicable Algebra in Engineering, Communications and Computing, +Volume 18, Number 3, May, 2007, pp. 223-239 +

          4 +
          P. D'Ambra, S. Filippone, D. Di Serafino
          +On the Development of PSBLAS-based Parallel Two-level Schwarz Preconditioners +
          +Applied Numerical Mathematics, Elsevier Science, +Volume 57, Issues 11-12, November-December 2007, Pages 1181-1196. + +

          +

          5 +
          + Dongarra, J. J., DuCroz, J., Hammarling, S. and Hanson, R., +An Extended Set of Fortran Basic Linear Algebra Subprograms, +ACM Trans. Math. Softw. vol. 14, 1-17, 1988. +

          6 +
          + Dongarra, J., DuCroz, J., Hammarling, S. and Duff, I., +A Set of level 3 Basic Linear Algebra Subprograms, +ACM Trans. Math. Softw. vol. 16, 1-17, 1990. +

          7 +
          +J. J. Dongarra and R. C. Whaley, +A User's Guide to the BLACS v. 1.1, +Lapack Working Note 94, Tech. Rep. UT-CS-95-281, University of +Tennessee, March 1995 (updated May 1997). +

          8 +
          +I. Duff, M. Marrone, G. Radicati and C. Vittoli, +Level 3 Basic Linear Algebra Subprograms for Sparse Matrices: +a User Level Interface, +ACM Transactions on Mathematical Software, 23(3), pp. 379-401, 1997. +

          9 +
          +I. Duff, M. Heroux and R. Pozo, +An Overview of the Sparse Basic Linear +Algebra Subprograms: the New Standard from the BLAS Technical Forum, +ACM Transactions on Mathematical Software, 28(2), pp. 239-267, 2002. +

          10 +
          +S. Filippone and M. Colajanni, +PSBLAS: A Library for Parallel Linear Algebra +Computation on Sparse Matrices, +
          +ACM Transactions on Mathematical Software, 26(4), pp. 527-550, 2000. +

          11 +
          +S. Filippone and A. Buttari, +Object-Oriented Techniques for Sparse Matrix Computations in Fortran 2003, +
          +ACM Transactions on Mathematical Software, 38(4), 2012. +

          12 +
          +S. Filippone, P. D'Ambra, M. Colajanni, +Using a Parallel Library of Sparse Linear Algebra in a Fluid Dynamics +Applications Code on Linux Clusters, +in G. Joubert, A. Murli, F. Peters, M. Vanneschi, editors, +Parallel Computing - Advances & Current Issues, +pp. 441-448, Imperial College Press, 2002. +

          13 +
          + Gamma, E., Helm, R., Johnson, R., and Vlissides, + J. 1995. + Design Patterns: Elements of Reusable Object-Oriented Software. + Addison-Wesley. + +

          +

          14 +
          +Karypis, G. and Kumar, V., +METIS: Unstructured Graph Partitioning and Sparse Matrix + Ordering System. +Minneapolis, MN 55455: University of Minnesota, Department of + Computer Science, 1995. +Internet Address: http://www.cs.umn.edu/~karypis. +

          15 +
          +Lawson, C., Hanson, R., Kincaid, D. and Krogh, F., + Basic Linear Algebra Subprograms for Fortran usage, +ACM Trans. Math. Softw. vol. 5, 38-329, 1979. + +

          +

          16 +
          +Machiels, L. and Deville, M. +Fortran 90: An entry to object-oriented programming for the solution + of partial differential equations. +ACM Trans. Math. Softw. vol. 23, 32-49. +

          17 +
          +Metcalf, M., Reid, J. and Cohen, M. +Fortran 95/2003 explained. +Oxford University Press, 2004. +

          18 +
          +Rouson, D.W.I., Xia, J., Xu, X.: Scientific Software Design: The + Object-Oriented Way. Cambridge University Press (2011) + +

          +

          19 +
          +M. Snir, S. Otto, S. Huss-Lederman, D. Walker and J. Dongarra, +MPI: The Complete Reference. Volume 1 - The MPI Core, second edition, +MIT Press, 1998. +
          + +

          +

          + + + diff --git a/docs/html/node135.html b/docs/html/node135.html new file mode 100644 index 000000000..5079b00a7 --- /dev/null +++ b/docs/html/node135.html @@ -0,0 +1,67 @@ + + + + + +About this document ... + + + + + + + + + + + + + + + + +
          +next + +up + +previous + +contents +
          + Up: userhtml + Previous: Bibliography +   Contents +
          +
          + + +

          +About this document ... +

          +

          +This document was generated using the +LaTeX2HTML translator Version 2018 (Released Feb 1, 2018) +

          +Copyright © 1993, 1994, 1995, 1996, +Nikos Drakos, +Computer Based Learning Unit, University of Leeds. +
          +Copyright © 1997, 1998, 1999, +Ross Moore, +Mathematics Department, Macquarie University, Sydney. +

          +The command line arguments were:
          + latex2html -local_icons -noaddress -dir ../../html userhtml.tex +

          +The translation was initiated on 2018-09-05 +

          + + + diff --git a/docs/html/node3.html b/docs/html/node3.html index 9d55ff44f..daf5854ca 100644 --- a/docs/html/node3.html +++ b/docs/html/node3.html @@ -56,7 +56,7 @@ General overview The PSBLAS library is designed to handle the implementation of iterative solvers for sparse linear systems on distributed memory parallel computers. The system coefficient matrix $A$ must be square; it may be real or complex, nonsymmetric, and its sparsity pattern diff --git a/docs/html/node4.html b/docs/html/node4.html index 1fd13393a..5921c2e5b 100644 --- a/docs/html/node4.html +++ b/docs/html/node4.html @@ -62,21 +62,21 @@ PDE. Each point of the discretization mesh will have (at least) one associated equation/variable, and therefore one index. We say that point $i$ depends on point $j$ if the equation for a variable associated with $i$ contains a term in $j$, or equivalently if $a_{ij} \ne0$. After the partition of the discretization mesh into sub-domains @@ -129,19 +129,19 @@ work [ We denote the sets of internal, boundary and halo points for a given subdomain by $\cal I$, $\cal B$ and $\cal H$. Each subdomain is assigned to one process; each process usually owns one subdomain, although the user may choose to assign more than one subdomain to a process. If each process $i$ owns one subdomain, the number of rows in the local sparse matrix is @@ -149,7 +149,7 @@ subdomain, the number of rows in the local sparse matrix is $|{\cal I}_i| + |{\cal B}_i|$ --> $\vert{\cal I}_i\vert + \vert{\cal B}_i\vert$, and the number of local columns (i.e. those for which there exists at least one non-zero entry in the @@ -157,7 +157,7 @@ local rows) is $\vert{\cal I}_i\vert + \vert{\cal B}_i\vert +\vert{\cal H}_i\vert$. @@ -170,7 +170,7 @@ Point classfication.
          \includegraphics[scale=0.65]{figures/points.eps} \begin{displaymath}dot \leftarrow x^H y\end{displaymath}
          @@ -121,13 +121,13 @@ Data types
          @@ -162,7 +162,7 @@ Data types
          x
          the local portion of global dense matrix $x$.
          @@ -175,17 +175,17 @@ Intent: in. Specified as: a rank one or two array or an object of type vdatapsb_T_vect_type containing numbers of type specified in Table 2. The rank of $x$ must be the same of $y$.
          y
          the local portion of global dense matrix $y$.
          @@ -198,10 +198,10 @@ Intent: in. Specified as: a rank one or two array or an object of type vdatapsb_T_vect_type containing numbers of type specified in Table 2. The rank of $y$ must be the same of $x$.
          @@ -236,10 +236,10 @@ Default: global=.true.
          Function value
          is the dot product of vectors $x$ and $y$.
          @@ -272,7 +272,7 @@ An integer value; 0 means no error has been detected. by using the following scheme:
          \begin{lstlisting} vres(1) = psb_gedot(x1,y1,desc_a,info,global=.false.) diff --git a/docs/html/node55.html b/docs/html/node55.html index f14e7e64d..7508d04db 100644 --- a/docs/html/node55.html +++ b/docs/html/node55.html @@ -55,10 +55,10 @@ psb_gedots -- Generalized Dot Product</A> <P> This subroutine computes a series of dot products among the columns of two dense matrices <SPAN CLASS=$x$ and $y$:

          @@ -70,7 +70,7 @@ res(i) \leftarrow x(:,i)^T y(:,i) --> \begin{displaymath}res(i) \leftarrow x(:,i)^T y(:,i)\end{displaymath} @@ -78,17 +78,17 @@ res(i) \leftarrow x(:,i)^T y(:,i)

          If the matrices are complex, then the usual convention applies, i.e. the conjugate transpose of $x$ is used. If $x$ and $y$ are of rank one, then $res$ is a scalar, else it is a rank one array. @@ -106,13 +106,13 @@ Data types
          $dot$, $x$, $y$ Function
          @@ -147,7 +147,7 @@ Data types
          x
          the local portion of global dense matrix $x$.
          @@ -160,17 +160,17 @@ Intent: in. Specified as: a rank one or two array or an object of type vdatapsb_T_vect_type containing numbers of type specified in Table 3. The rank of $x$ must be the same of $y$.
          y
          the local portion of global dense matrix $y$.
          @@ -183,10 +183,10 @@ Intent: in. Specified as: a rank one or two array or an object of type vdatapsb_T_vect_type containing numbers of type specified in Table 3. The rank of $y$ must be the same of $x$.
          @@ -206,10 +206,10 @@ Specified as: an object of type descdatapsb_desc_type.
          res
          is the dot product of vectors $x$ and $y$.
          diff --git a/docs/html/node56.html b/docs/html/node56.html index d626f7f67..29724b16b 100644 --- a/docs/html/node56.html +++ b/docs/html/node56.html @@ -55,12 +55,12 @@ psb_normi -- Infinity-Norm of Vector

          This function computes the infinity-norm of a vector $x$.
          If $x$ is a real vector it computes infinity norm as: @@ -73,14 +73,14 @@ amax \leftarrow \max_i |x_i| --> \begin{displaymath}amax \leftarrow \max_i \vert x_i\vert\end{displaymath}

          else if $x$ is a complex vector then it computes the infinity-norm as:

          @@ -92,7 +92,7 @@ amax \leftarrow \max_i {(|re(x_i)| + |im(x_i)|)} --> \begin{displaymath}amax \leftarrow \max_i {(\vert re(x_i)\vert + \vert im(x_i)\vert)}\end{displaymath} @@ -115,11 +115,11 @@ Data types
          $res$, $x$, $y$ Subroutine
          @@ -158,7 +158,7 @@ Data types
          x
          the local portion of global dense matrix $x$. @@ -205,7 +205,7 @@ Default: global=.true.
          Function value
          is the infinity norm of vector $x$.
          @@ -238,7 +238,7 @@ An integer value; 0 means no error has been detected. by using the following scheme:
          \begin{lstlisting} vres(1) = psb_geamax(x1,desc_a,info,global=.false.) diff --git a/docs/html/node57.html b/docs/html/node57.html index fdd2f842a..d48429415 100644 --- a/docs/html/node57.html +++ b/docs/html/node57.html @@ -55,7 +55,7 @@ psb_geamaxs -- Generalized Infinity Norm</A> <P> This subroutine computes a series of infinity norms on the columns of a dense matrix <SPAN CLASS=$x$:

          @@ -67,7 +67,7 @@ res(i) \leftarrow \max_k |x(k,i)| --> \begin{displaymath}res(i) \leftarrow \max_k \vert x(k,i)\vert \end{displaymath} @@ -89,11 +89,11 @@ Data types
          $amax$ $x$ Function
          @@ -132,7 +132,7 @@ Data types
          x
          the local portion of global dense matrix $x$.
          @@ -162,7 +162,7 @@ Specified as: an object of type descdatapsb_desc_type.
          res
          is the infinity norm of the columns of $x$.
          diff --git a/docs/html/node58.html b/docs/html/node58.html index c4fd28f7d..0d44280a2 100644 --- a/docs/html/node58.html +++ b/docs/html/node58.html @@ -54,12 +54,12 @@ psb_norm1 -- 1-Norm of Vector

          This function computes the 1-norm of a vector $x$.
          If $x$ is a real vector it computes 1-norm as: @@ -72,14 +72,14 @@ asum \leftarrow \|x_i\| --> \begin{displaymath}asum \leftarrow \Vert x_i\Vert\end{displaymath}

          else if $x$ is a complex vector then it computes 1-norm as:

          @@ -91,7 +91,7 @@ asum \leftarrow \|re(x)\|_1 + \|im(x)\|_1 --> \begin{displaymath}asum \leftarrow \Vert re(x)\Vert _1 + \Vert im(x)\Vert _1\end{displaymath} @@ -114,11 +114,11 @@ Data types
          $res$ $x$ Subroutine
          @@ -157,7 +157,7 @@ Data types
          x
          the local portion of global dense matrix $x$. @@ -203,7 +203,7 @@ Default: global=.true.
          Function value
          is the 1-norm of vector $x$.
          @@ -236,7 +236,7 @@ An integer value; 0 means no error has been detected. by using the following scheme:
          \begin{lstlisting} vres(1) = psb_geasum(x1,desc_a,info,global=.false.) diff --git a/docs/html/node59.html b/docs/html/node59.html index 4ab320ea4..93813f614 100644 --- a/docs/html/node59.html +++ b/docs/html/node59.html @@ -55,7 +55,7 @@ psb_geasums -- Generalized 1-Norm of Vector</A> <P> This subroutine computes a series of 1-norms on the columns of a dense matrix <SPAN CLASS=$x$:

          @@ -67,19 +67,19 @@ res(i) \leftarrow \max_k |x(k,i)| --> \begin{displaymath}res(i) \leftarrow \max_k \vert x(k,i)\vert \end{displaymath}

          This function computes the 1-norm of a vector $x$.
          If $x$ is a real vector it computes 1-norm as: @@ -92,14 +92,14 @@ res(i) \leftarrow \|x_i\| --> \begin{displaymath}res(i) \leftarrow \Vert x_i\Vert\end{displaymath}

          else if $x$ is a complex vector then it computes 1-norm as:

          @@ -111,7 +111,7 @@ res(i) \leftarrow \|re(x)\|_1 + \|im(x)\|_1 --> \begin{displaymath}res(i) \leftarrow \Vert re(x)\Vert _1 + \Vert im(x)\Vert _1\end{displaymath} @@ -133,11 +133,11 @@ Data types
          $asum$ $x$ Function
          @@ -176,7 +176,7 @@ Data types
          x
          the local portion of global dense matrix $x$. @@ -209,7 +209,7 @@ Specified as: an object of type descdatapsb_desc_type.
          res
          contains the 1-norm of (the columns of) $x$.
          diff --git a/docs/html/node6.html b/docs/html/node6.html index caab01361..a3f44e2fe 100644 --- a/docs/html/node6.html +++ b/docs/html/node6.html @@ -61,7 +61,7 @@ space to which there corresponds an index space and a matrix sparsity pattern. As an example, consider a cell-centered finite-volume discretization of the Navier-Stokes equations on a simulation domain; the index space $1\dots n$ is isomorphic to the set of cell centers, whereas the pattern of the associated linear system matrix is @@ -72,7 +72,7 @@ by the discretization stencil. Thus the first order of business is to establish an index space, and this is done with a call to psb_cdall in which we specify the size of the index space $n$ and the allocation of the elements of the index space to the various processes making up the MPI (virtual) @@ -81,22 +81,22 @@ parallel machine.

          The index space is partitioned among processes, and this creates a mapping from the “global” numbering $1\dots n$ to a numbering “local” to each process; each process $i$ will own a certain subset $1\dots n_{\hbox{row}_i}$, each element of which corresponds to a certain element of $1\dots n$. The user does not set explicitly this mapping; when the application needs to indicate to which element of the index @@ -106,7 +106,7 @@ library will translate into the appropriate “local” numbering.

          For a given index space $1\dots n$ there are many possible associated topologies, i.e. many different discretization stencils; thus the @@ -115,7 +115,7 @@ defined a sparsity pattern, either explicitly through psb_cdins or implicitly through psb_spins. The descriptor is finalized with a call to psb_cdasb and a sparse matrix with a call to psb_spasb. After psb_cdasb each process $i$ will have defined a set of “halo” (or “ghost”) indices @@ -123,16 +123,16 @@ defined a set of “halo” (or “ghost”) indices $n_{\hbox{row}_i}+1\dots n_{\hbox{col}_i}$ --> $n_{\hbox{row}_i}+1\dots n_{\hbox{col}_i}$, denoting elements of the index space that are not assigned to process $i$; however the variables associated with them are needed to complete computations associated with the sparse matrix $A$, and thus they have to be fetched from (neighbouring) processes. The descriptor of the index @@ -173,8 +173,8 @@ follows:

        2. Call the iterative method of choice, e.g. psb_bicgstab
          3. -This is the structure of the sample program -test/pargen/psb_d_pde3d.f90. +This is the structure of the sample programs in the directory +test/pargen/.

          For a simulation in which the same discretization mesh is used over diff --git a/docs/html/node60.html b/docs/html/node60.html index f663ca4c1..06530a6be 100644 --- a/docs/html/node60.html +++ b/docs/html/node60.html @@ -54,12 +54,12 @@ psb_norm2 -- 2-Norm of Vector

          This function computes the 2-norm of a vector $x$.
          If $x$ is a real vector it computes 2-norm as: @@ -72,14 +72,14 @@ nrm2 \leftarrow \sqrt{x^T x} --> \begin{displaymath}nrm2 \leftarrow \sqrt{x^T x}\end{displaymath}

          else if $x$ is a complex vector then it computes 2-norm as:

          @@ -91,7 +91,7 @@ nrm2 \leftarrow \sqrt{x^H x} --> \begin{displaymath}nrm2 \leftarrow \sqrt{x^H x}\end{displaymath} @@ -108,11 +108,11 @@ Data types
          $res$ $x$ Subroutine
          @@ -157,7 +157,7 @@ psb_norm2(x, desc_a, info [,global])
          x
          the local portion of global dense matrix $x$.
          @@ -203,7 +203,7 @@ Default: global=.true.
          Function Value
          is the 2-norm of vector $x$.
          @@ -238,7 +238,7 @@ An integer value; 0 means no error has been detected. by using the following scheme:
          \begin{lstlisting} vres(1) = psb_genrm2(x1,desc_a,info,global=.false.) diff --git a/docs/html/node61.html b/docs/html/node61.html index 867d4545d..98f926ebb 100644 --- a/docs/html/node61.html +++ b/docs/html/node61.html @@ -55,7 +55,7 @@ psb_genrm2s -- Generalized 2-Norm of Vector</A> <P> This subroutine computes a series of 2-norms on the columns of a dense matrix <SPAN CLASS=$x$:

          @@ -67,7 +67,7 @@ res(i) \leftarrow \|x(:,i)\|_2 --> \begin{displaymath}res(i) \leftarrow \Vert x(:,i)\Vert _2 \end{displaymath} @@ -89,11 +89,11 @@ Data types
          $nrm2$ $x$ Function
          @@ -132,7 +132,7 @@ Data types
          x
          the local portion of global dense matrix $x$. @@ -165,7 +165,7 @@ Specified as: an object of type descdatapsb_desc_type.
          res
          contains the 1-norm of (the columns of) $x$.
          diff --git a/docs/html/node62.html b/docs/html/node62.html index 6ef4e36db..6fed831b4 100644 --- a/docs/html/node62.html +++ b/docs/html/node62.html @@ -54,7 +54,7 @@ psb_norm1 -- 1-Norm of Sparse Matrix

          This function computes the 1-norm of a matrix $A$:
          @@ -68,7 +68,7 @@ nrm1 \leftarrow \|A\|_1 --> \begin{displaymath}nrm1 \leftarrow \Vert A\Vert _1 \end{displaymath} @@ -77,11 +77,11 @@ nrm1 \leftarrow \|A\|_1 where:

          $A$
          represents the global matrix $A$
          @@ -97,7 +97,7 @@ Data types
          $res$ $x$ Subroutine
          @@ -138,7 +138,7 @@ psb_norm1(A, desc_a, info)
          a
          the local portion of the global sparse matrix $A$.
          @@ -166,7 +166,7 @@ Specified as: an object of type descdatapsb_desc_type.
          Function value
          is the 1-norm of sparse submatrix $A$.
          diff --git a/docs/html/node63.html b/docs/html/node63.html index d084adad1..93e7b13b9 100644 --- a/docs/html/node63.html +++ b/docs/html/node63.html @@ -54,7 +54,7 @@ psb_normi -- Infinity Norm of Sparse Matrix

          This function computes the infinity-norm of a matrix $A$:
          @@ -68,7 +68,7 @@ nrmi \leftarrow \|A\|_\infty --> \begin{displaymath}nrmi \leftarrow \Vert A\Vert _\infty \end{displaymath} @@ -77,11 +77,11 @@ nrmi \leftarrow \|A\|_\infty where:

          $A$
          represents the global matrix $A$
          @@ -97,7 +97,7 @@ Data types
          $A$ Function
          @@ -138,7 +138,7 @@ psb_normi(A, desc_a, info)
          a
          the local portion of the global sparse matrix $A$.
          @@ -166,7 +166,7 @@ Specified as: an object of type descdatapsb_desc_type.
          Function value
          is the infinity-norm of sparse submatrix $A$.
          diff --git a/docs/html/node64.html b/docs/html/node64.html index 9f15d14c7..9c6f77944 100644 --- a/docs/html/node64.html +++ b/docs/html/node64.html @@ -88,7 +88,7 @@ y \leftarrow \alpha A^T x + \beta y
          $A$ Function
          \begin{displaymath} y \leftarrow \alpha A^T x + \beta y @@ -122,29 +122,29 @@ y \leftarrow \alpha A^H x + \beta y where: <DL> <DT><STRONG><SPAN CLASS=$x$
          is the global dense matrix $x_{:, :}$
          $y$
          is the global dense matrix $y_{:, :}$
          $A$
          is the global sparse matrix $A$
          @@ -160,19 +160,19 @@ Data types
          @@ -213,7 +213,7 @@ call psb_spmm(alpha, a, x, beta, y,desc_a, info, &
          alpha
          the scalar $\alpha$.
          @@ -229,7 +229,7 @@ Table 12.
          a
          the local portion of the sparse matrix $A$.
          @@ -244,7 +244,7 @@ Specified as: an object of type spdatapsb_Tspmat_type.
          x
          the local portion of global dense matrix $x$. @@ -258,16 +258,16 @@ Intent: in. Specified as: a rank one or two array or an object of type vdatapsb_T_vect_type containing numbers of type specified in Table 12. The rank of $x$ must be the same of $y$.
          beta
          the scalar $\beta$.
          @@ -282,7 +282,7 @@ Specified as: a number of the data type indicated in Table $y$. @@ -296,10 +296,10 @@ Intent: inout. Specified as: a rank one or two array or an object of type vdatapsb_T_vect_type containing numbers of type specified in Table 12. The rank of $y$ must be the same of $x$.
          @@ -336,7 +336,7 @@ Type: optional Intent: in.
          Default: $trans = N$
          @@ -354,10 +354,10 @@ Type: optional Intent: inout.
          Specified as: a rank one array of the same type of $x$ and $y$ with the TARGET attribute. @@ -369,7 +369,7 @@ the TARGET attribute.
          y
          the local portion of result matrix $y$.
          diff --git a/docs/html/node65.html b/docs/html/node65.html index 7617d650b..8ea771436 100644 --- a/docs/html/node65.html +++ b/docs/html/node65.html @@ -86,34 +86,34 @@ y &\leftarrow& \alpha T^{-H} D x + \beta y\\ where:
          $x$
          is the global dense matrix $x_{:, :}$
          $y$
          is the global dense matrix $y_{:, :}$
          $T$
          is the global sparse block triangular submatrix $T$
          $D$
          is the scaling diagonal matrix. @@ -137,22 +137,22 @@ Data types
          $A$, $x$, $y$, $\alpha$, $\beta$ Subroutine
          @@ -186,7 +186,7 @@ Data types
          alpha
          the scalar $\alpha$.
          @@ -202,7 +202,7 @@ Table 13.
          t
          the global portion of the sparse matrix $T$.
          @@ -218,7 +218,7 @@ Specified as: an object type specified in
          x
          the local portion of global dense matrix $x$. @@ -232,16 +232,16 @@ Intent: in. Specified as: a rank one or two array or an object of type vdatapsb_T_vect_type containing numbers of type specified in Table 13. The rank of $x$ must be the same of $y$.
          beta
          the scalar $\beta$.
          @@ -256,7 +256,7 @@ Specified as: a number of the data type indicated in Table $y$. @@ -270,10 +270,10 @@ Intent: inout. Specified as: a rank one or two array or an object of type vdatapsb_T_vect_type containing numbers of type specified in Table 13. The rank of $y$ must be the same of $x$.
          @@ -308,7 +308,7 @@ Type: optional Intent: in.
          Default: $trans = N$
          @@ -334,7 +334,7 @@ Type: optional Intent: in.
          Default: $unitd = U$
          @@ -380,7 +380,7 @@ Default: $diag(1) = 1 (no scaling)$
          @@ -397,7 +397,7 @@ Type: optional Intent: inout.
          Specified as: a rank one array of the same type of $x$ with the TARGET attribute. @@ -410,7 +410,7 @@ TARGET attribute.
          y
          the local portion of global dense matrix $y$. diff --git a/docs/html/node67.html b/docs/html/node67.html index 1ab4ea308..763375097 100644 --- a/docs/html/node67.html +++ b/docs/html/node67.html @@ -75,7 +75,7 @@ x \leftarrow x where:
          $x$
          is a global dense submatrix. @@ -92,10 +92,10 @@ Data types
          $T$, $x$, $y$, $D$, $\alpha$, $\beta$ Subroutine
          @@ -125,7 +125,7 @@ Data types


          \begin{lstlisting} call psb_halo(x, desc_a, info) @@ -143,7 +143,7 @@ call psb_halo(x, desc_a, info, work, data) </DD> <DT><STRONG>x</STRONG></DT> <DD>global dense matrix <SPAN CLASS=$x$.
          @@ -178,7 +178,7 @@ Type: optional Intent: inout.
          Specified as: a rank one array of the same type of $x$. @@ -200,7 +200,7 @@ index list on which to base the data exchange.

          x
          global dense result matrix $x$.
          @@ -216,7 +216,7 @@ Table 14.
          info
          the local portion of result submatrix $y$.
          @@ -237,12 +237,12 @@ Sample discretization mesh.
          $\alpha$, $x$ Subroutine
          \includegraphics[scale=0.45]{figures/try8x8.eps} \includegraphics[scale=0.45]{figures/try8x8} @@ -258,7 +258,7 @@ distribution is such that each process will own 32 entries in the index space, with a halo made of 8 entries placed at local indices 33 through 40. If process 0 assigns an initial value of 1 to its entries in the $x$ vector, and process 1 assigns a value of 2, then after a call to psb_halo the contents of the local vectors will be the diff --git a/docs/html/node68.html b/docs/html/node68.html index eff574f40..9dcdb8854 100644 --- a/docs/html/node68.html +++ b/docs/html/node68.html @@ -74,11 +74,11 @@ x \leftarrow Q x where:
          $x$
          is the global dense submatrix $x$
          @@ -91,7 +91,7 @@ operators $P_a$ and $P^{T}$. @@ -107,7 +107,7 @@ Data types
          @@ -134,7 +134,7 @@ Data types


          \begin{lstlisting} call psb_ovrl(x, desc_a, info) @@ -152,7 +152,7 @@ call psb_ovrl(x, desc_a, info, update=update_type, work=work) </DD> <DT><STRONG>x</STRONG></DT> <DD>global dense matrix <SPAN CLASS=$x$.
          @@ -185,13 +185,13 @@ Specified as: a structured data of type descdatapsb_desc_type.

          update = psb_add_
          Sum overlap entries, i.e. apply $P^T$;
          update = psb_avg_
          Average overlap entries, i.e. apply $P_aP^T$;
          @@ -222,7 +222,7 @@ Type: optional Intent: inout.
          Specified as: a one dimensional array of the same type of $x$. @@ -233,7 +233,7 @@ Specified as: a one dimensional array of the same type of
          x
          global dense result matrix $x$.
          @@ -268,11 +268,11 @@ An integer value; 0 means no error has been detected. the descriptor, no operations are performed;
        3. The operator $P^{T}$ performs the reduction sum of overlap elements; it is a “prolongation” operator $P^T$ that replicates overlap elements, accounting for the physical replication @@ -297,12 +297,12 @@ Sample discretization mesh.
          4. $x$ Subroutine
          \includegraphics[scale=0.65]{figures/try8x8_ov.eps} \includegraphics[scale=0.65]{figures/try8x8_ov} @@ -319,7 +319,7 @@ distribution is such that each process will own 40 entries in the index space, with an overlap of 16 entries placed at local indices 25 through 40; the halo will run from local index 41 through local index 48.. If process 0 assigns an initial value of 1 to its entries in the $x$ vector, and process 1 assigns a value of 2, then after a call to psb_ovrl with psb_avg_ and a call to diff --git a/docs/html/node69.html b/docs/html/node69.html index 79a9d84cf..45aa92feb 100644 --- a/docs/html/node69.html +++ b/docs/html/node69.html @@ -67,7 +67,7 @@ glob\_x \leftarrow collect(loc\_x_i) --> \begin{displaymath}glob\_x \leftarrow collect(loc\_x_i) \end{displaymath}
          @@ -83,22 +83,22 @@ where: $glob\_x_{1:m,1:n}$ --> $glob\_x_{1:m,1:n}$
          $loc\_x_i$
          is the local portion of global dense matrix on process $i$.
          $collect$
          is the collect function. @@ -115,7 +115,7 @@ Data types
          @@ -145,7 +145,7 @@ Data types


          \begin{lstlisting} call psb_gather(glob_x, loc_x, desc_a, info, root) @@ -190,7 +190,7 @@ Specified as: a structured data of type descdata<TT>psb_desc_type</TT>. </DD> <DT><STRONG>root</STRONG></DT> <DD>The process that holds the global copy. If <SPAN CLASS=$root=-1$ all the processes will have a copy of the global vector. @@ -205,10 +205,10 @@ Specified as: an integer variable $-1\le root\le np-1$, default $-1$. diff --git a/docs/html/node7.html b/docs/html/node7.html index 155a14f7a..2a9ab1419 100644 --- a/docs/html/node7.html +++ b/docs/html/node7.html @@ -61,7 +61,7 @@ to the constraints outlined in sec. 2.3< $1\dots n_{\hbox{row}_i}$ --> $1\dots n_{\hbox{row}_i}$; @@ -70,7 +70,7 @@ to the constraints outlined in sec. 2.3< $n_{\hbox{row}_i}+1\dots n_{\hbox{col}_i}$ --> $n_{\hbox{row}_i}+1\dots n_{\hbox{col}_i}$; diff --git a/docs/html/node70.html b/docs/html/node70.html index d16ab5109..703c638fa 100644 --- a/docs/html/node70.html +++ b/docs/html/node70.html @@ -65,7 +65,7 @@ loc\_x_i \leftarrow scatter(glob\_x) --> \begin{displaymath}loc\_x_i \leftarrow scatter(glob\_x) \end{displaymath} @@ -81,22 +81,22 @@ where: $glob\_x_{1:m,1:n}$ --> $glob\_x_{1:m,1:n}$

          $loc\_x_i$
          is the local portion of global dense matrix on process $i$.
          $scatter$
          is the scatter function. @@ -113,7 +113,7 @@ Data types
          $x_i, y$ Subroutine
          @@ -143,7 +143,7 @@ Data types


          \begin{lstlisting} call psb_scatter(glob_x, loc_x, desc_a, info, root, mold) @@ -182,7 +182,7 @@ Specified as: a structured data of type descdata<TT>psb_desc_type</TT>. </DD> <DT><STRONG>root</STRONG></DT> <DD>The process that holds the global copy. If <SPAN CLASS=$root=-1$ all the processes have a copy of the global vector. @@ -197,7 +197,7 @@ Specified as: an integer variable $-1\le root\le np-1$, default psb_root_, i.e. process 0. diff --git a/docs/html/node72.html b/docs/html/node72.html index 6277372ec..d5a21bbe8 100644 --- a/docs/html/node72.html +++ b/docs/html/node72.html @@ -90,11 +90,11 @@ Specified as: an integer value. $i\in \{1\dots mg\}$ --> $i\in \{1\dots mg\}$ is allocated to process $vg(i)$.
          @@ -108,7 +108,7 @@ Specified as: an integer array.

          flag
          Specifies whether entries in $vg$ are zero- or one-based.
          @@ -119,10 +119,10 @@ Type:optional. Intent: in.
          Specified as: an integer value $0,1$, default $0$. @@ -152,7 +152,7 @@ Specified as: a subroutine.
          vl
          Data allocation: the set of global indices $vl(1:nl)$ belonging to the calling process.
          @@ -204,10 +204,10 @@ Specified as: a logical value, default: .false.
          lidx
          Data allocation: the set of local indices $lidx(1:nl)$ to be assigned to the global indices $vl$.
          @@ -300,10 +300,10 @@ An integer value; 0 means no error has been detected. $0\le pv(i) < np$ --> $0\le pv(i) < np$; if $nv>1$ we have an index assigned to multiple processes, i.e. we have an overlap among the subdomains. @@ -318,23 +318,23 @@ An integer value; 0 means no error has been detected. $i \in \{1\dots mg\}$ --> $i\in \{1\dots mg\}$ is assigned to process $vg(i)$. The vector vg must be identical on all calling processes; its entries may have the ranges $(0\dots np-1)$ or $(1\dots np)$ according to the value of flag. The size $mg$ may be specified via the optional argument mg; the default is to use the entire vector vg, thus having @@ -344,7 +344,7 @@ An integer value; 0 means no error has been detected.
          In this case we are specifying the list of indices vl(1:nl) assigned to the current process; thus, the global problem size $mg$ is given by the range of the aggregate of the individual vectors vl specified @@ -353,7 +353,7 @@ An integer value; 0 means no error has been detected. vl, thus having nl=size(vl). If globalcheck=.true. the subroutine will check how many times each entry in the global index space $(1\dots mg)$ is specified in the input lists vl, thus allowing for the @@ -377,7 +377,7 @@ An integer value; 0 means no error has been detected.
          If this argument is specified alone (i.e. without vl) the result is a generalized row-block distribution in which each process $I$ gets assigned a consecutive chunk of $ia(i),ja(i)$; the starting index $ia(i)$ should belong to the current process. In the second form only the remote indices $ja(i)$ are specified. @@ -106,7 +106,7 @@ Type: required. Intent: in.
          Specified as: an integer array of length $nz$.
          @@ -120,7 +120,7 @@ Type: required. Intent: in.
          Specified as: an integer array of length $nz$. @@ -135,7 +135,7 @@ Type: optional. Intent: in.
          Specified as: a logical array of length $nz$, default .true.. @@ -149,7 +149,7 @@ Type: optional. Intent: in.
          Specified as: an integer array of length $nz$. @@ -192,7 +192,7 @@ Type: optional. Intent: out.
          Specified as: an integer array of length $nz$. @@ -206,7 +206,7 @@ Type: optional. Intent: out.
          Specified as: an integer array of length $nz$. diff --git a/docs/html/node77.html b/docs/html/node77.html index 9716704ac..642c016bf 100644 --- a/docs/html/node77.html +++ b/docs/html/node77.html @@ -100,7 +100,7 @@ Type:required. Intent: in.
          Specified as: an integer value $nl\ge 0$. diff --git a/docs/html/node78.html b/docs/html/node78.html index 42ebd8018..813486b61 100644 --- a/docs/html/node78.html +++ b/docs/html/node78.html @@ -127,7 +127,7 @@ An integer value; 0 means no error has been detected.
        4. The descriptor may be in either the build or assembled state.
        5. Providing a good estimate for the number of nonzeroes $nnz$ in the assembled matrix may substantially improve performance in the diff --git a/docs/html/node79.html b/docs/html/node79.html index ddef55688..79ba9ba0f 100644 --- a/docs/html/node79.html +++ b/docs/html/node79.html @@ -87,7 +87,7 @@ Type:required. Intent: in.
          Specified as: an integer array of size $nz$. @@ -101,7 +101,7 @@ Type:required. Intent: in.
          Specified as: an integer array of size $nz$. @@ -115,11 +115,11 @@ Type:required. Intent: in.
          Specified as: an array of size $nz$. Must be of the same type and kind of the coefficients of the sparse matrix $a$. @@ -210,14 +210,14 @@ An integer value; 0 means no error has been detected. $ia(i),ja(i),val(i)$ --> $ia(i),ja(i),val(i)$, for $i=1,\dots,nz$; these triples should belong to the current process, i.e. $ia(i)$ should be one of the local indices, but are otherwise arbitrary; diff --git a/docs/html/node83.html b/docs/html/node83.html index 46fd98a06..6acda5441 100644 --- a/docs/html/node83.html +++ b/docs/html/node83.html @@ -89,7 +89,7 @@ Specified as: Integer scalar, default $1$. It is not a valid argument if $x$ is a rank-1 array. @@ -107,7 +107,7 @@ Specified as: Integer scalar, default $1$. It is not a valid argument if $x$ is a rank-1 array. diff --git a/docs/html/node84.html b/docs/html/node84.html index 92f45b5ea..619397e91 100644 --- a/docs/html/node84.html +++ b/docs/html/node84.html @@ -67,7 +67,7 @@ call psb_geins(m, irw, val, x, desc_a, info [,dupl,local])
          m
          Number of rows in $val$ to be inserted.
          @@ -81,15 +81,15 @@ Specified as: an integer value.
          irw
          Indices of the rows to be inserted. Specifically, row $i$ of $val$ will be inserted into the local row corresponding to the global row index $irw(i)$. Scope:local. diff --git a/docs/html/node85.html b/docs/html/node85.html index 3a23b931b..c1ef7600c 100644 --- a/docs/html/node85.html +++ b/docs/html/node85.html @@ -87,7 +87,7 @@ Intent: in.
          Specified as: an object of a class derived from vbasedatapsb_T_base_vect_type; this is only allowed when $x$ is of type vdatapsb_T_vect_type.
          diff --git a/docs/html/node87.html b/docs/html/node87.html index 4ca7bac53..ba93aeba7 100644 --- a/docs/html/node87.html +++ b/docs/html/node87.html @@ -68,10 +68,10 @@ call psb_gelp(trans, iperm, x, info)
          trans
          A character that specifies whether to permute $A$ or $A^T$.
          @@ -82,10 +82,10 @@ Type: required Intent: in.
          Specified as: a single character with value 'N' for $A$ or 'T' for $A^T$.
          diff --git a/docs/html/node88.html b/docs/html/node88.html index 562054789..b84366b76 100644 --- a/docs/html/node88.html +++ b/docs/html/node88.html @@ -121,11 +121,11 @@ accepted. Default: false.
          x
          If $y$ is not present, then $x$ is overwritten with the translated integer indices. Scope: global @@ -138,14 +138,14 @@ Specified as: a rank one integer array.
          y
          If $y$ is present, then $y$ is overwritten with the translated integer indices, and $x$ is left unchanged. diff --git a/docs/html/node89.html b/docs/html/node89.html index ac2750955..6c3236b61 100644 --- a/docs/html/node89.html +++ b/docs/html/node89.html @@ -109,11 +109,11 @@ Specified as: a character variable Ignore, Warning or
          x
          If $y$ is not present, then $x$ is overwritten with the translated integer indices. Scope: global @@ -126,14 +126,14 @@ Specified as: a rank one integer array.
          y
          If $y$ is not present, then $y$ is overwritten with the translated integer indices, and $x$ is left unchanged. diff --git a/docs/html/node9.html b/docs/html/node9.html index 754b8beff..b60f74d37 100644 --- a/docs/html/node9.html +++ b/docs/html/node9.html @@ -79,20 +79,26 @@ defined in the library as follows: data; corresponds to a DOUBLE PRECISION declaration and is normally 8 bytes;
          -
          psb_ipk_
          -
          Kind parameter for integer data; - with default build options this is a 4 bytes integer, but there is - (highly) experimental support for 8-bytes integers; -
          -
          psb_mpik_
          +
          psb_mpk_
          Kind parameter for 4-bytes integer data, as is always used by MPI;
          -
          psb_long_int_k_
          -
          Kind parameter for long (8 bytes) integers, - which are always used by the sizeof methods. +
          psb_epk_
          +
          Kind parameter for 8-bytes integer data, as is + always used by the sizeof methods; +
          +
          psb_ipk_
          +
          Kind parameter for “local” integer indices and data; + with default build options this is a 4 bytes integer; +
          +
          psb_lpk_
          +
          Kind parameter for “global” integer indices and data; + with default build options this is an 8 bytes integer;
          +The integer kinds for local and global indices can be chosen at +configure time to hold 4 or 8 bytes, with the global indices at least +as large as the local ones. Together with the classes attributes we also discuss their methods. Most methods detailed here only act on the local variable, i.e. their action is purely local and asynchronous unless otherwise diff --git a/docs/html/node90.html b/docs/html/node90.html index aaf6d3e32..fee6dd3a7 100644 --- a/docs/html/node90.html +++ b/docs/html/node90.html @@ -97,7 +97,7 @@ Specified as: a structured data of type descdatapsb_desc_type.
          Function value
          A logical mask which is true if $x$ is owned by the current process Scope: local diff --git a/docs/html/node91.html b/docs/html/node91.html index d2bd979c5..00db2a3e1 100644 --- a/docs/html/node91.html +++ b/docs/html/node91.html @@ -108,7 +108,7 @@ Specified as: a character variable Ignore, Warning or
          y
          A logical mask which is true for all corresponding entries of $x$ that are owned by the current process Scope: local diff --git a/docs/html/node92.html b/docs/html/node92.html index a3c4d4b6f..725dc1183 100644 --- a/docs/html/node92.html +++ b/docs/html/node92.html @@ -97,7 +97,7 @@ Specified as: a structured data of type descdatapsb_desc_type.
          Function value
          A logical mask which is true if $x$ is local to the current process Scope: local diff --git a/docs/html/node93.html b/docs/html/node93.html index 3a12cab90..8ff5d6267 100644 --- a/docs/html/node93.html +++ b/docs/html/node93.html @@ -108,7 +108,7 @@ Specified as: a character variable Ignore, Warning or
          y
          A logical mask which is true for all corresponding entries of $x$ that are local to the current process Scope: local diff --git a/docs/html/node96.html b/docs/html/node96.html index 59c77237d..edc50c149 100644 --- a/docs/html/node96.html +++ b/docs/html/node96.html @@ -77,7 +77,7 @@ Type:required Intent: in.
          Specified as: an integer $>0$.
          @@ -113,7 +113,7 @@ Type:optional Intent: in.
          Specified as: an integer $>0$. When append is true, specifies how many entries in the output vectors are already filled. @@ -128,10 +128,10 @@ Type:optional Intent: in.
          Specified as: an integer $>0$, default: $row$. @@ -206,12 +206,12 @@ An integer value; 0 means no error has been detected.
          1. The output $nz$ is always the size of the output generated by the current call; thus, if append=.true., the total output size will be $nzin+nz$, with the newly extracted coefficients stored in entries nzin+1:nzin+nz of the array arguments; diff --git a/docs/html/node97.html b/docs/html/node97.html index 9a4468313..8e84eafa2 100644 --- a/docs/html/node97.html +++ b/docs/html/node97.html @@ -73,7 +73,7 @@ isz = psb_sizeof(prec)
            a
            A sparse matrix $A$.
            diff --git a/docs/html/node98.html b/docs/html/node98.html index 79c9b3076..f98f71783 100644 --- a/docs/html/node98.html +++ b/docs/html/node98.html @@ -69,7 +69,7 @@ call psb_hsort(x,ix,dir,flag)

            These serial routines sort a sequence $X$ into ascending or descending order. The argument meaning is identical for the three @@ -95,7 +95,7 @@ Specified as: an integer, real or complex array of rank 1. Type:optional.
            Specified as: an integer array of (at least) the same size as $X$.

            @@ -119,7 +119,7 @@ default psb_lsort_up_.
            flag
            Whether to keep the original values in $IX$.
            @@ -151,7 +151,7 @@ Type: Optional
            An integer array of rank 1, whose entries are moved to the same position as the corresponding entries in $x$.
            @@ -181,35 +181,35 @@ position as the corresponding entries in $flag = psb\_sort\_ovw\_idx\_$ then the entries in $ix(1:n)$ where $n$ is the size of $x$ are initialized to $ix(i) \leftarrow i$; thus, upon return from the subroutine, for each index $i$ we have in $ix(i)$ the position that the item $x(i)$ occupied in the original data sequence; @@ -218,16 +218,16 @@ i$">; thus, upon return from the subroutine, for each $flag = psb\_sort\_keep\_idx\_$ --> $flag = psb\_sort\_keep\_idx\_$ the routine will assume that the entries in $ix(:)$ have already been initialized by the user;
          2. The three sorting algorithms have a similar $O(n \log n)$ expected running time; in the average case quicksort will be the @@ -235,7 +235,7 @@ i$">; thus, upon return from the subroutine, for each
            1. The worst case running time for quicksort is $O(n^2)$; the algorithm implemented here follows the well-known median-of-three heuristics, @@ -243,7 +243,7 @@ i$">; thus, upon return from the subroutine, for each
            2. The worst case running time for merge-sort and heap-sort is $O(n \log n)$ as the average case;
              3. diff --git a/docs/psblas-3.6.pdf b/docs/psblas-3.6.pdf index d9d36c978..1965fd028 100644 --- a/docs/psblas-3.6.pdf +++ b/docs/psblas-3.6.pdf @@ -453,17 +453,17 @@ stream 0 g 0 G 0 g 0 G BT -/F16 24.7871 Tf 135.453 564.641 Td [(PSBLAS)-375(3.6.0)-375(User's)-375(guide)]TJ +/F16 24.7871 Tf 135.453 563.395 Td [(PSBLAS)-375(3.6.0)-375(User's)-375(guide)]TJ ET q -1 0 0 1 125.3 548.396 cm +1 0 0 1 125.3 547.151 cm 0 0 343.711 4.981 re f Q BT -/F18 14.3462 Tf 132.314 526.714 Td [(A)-350(r)50(efer)50(enc)50(e)-350(guide)-350(for)-350(the)-350(Par)50(al)-50(lel)-350(Sp)50(arse)-350(BLAS)-350(libr)50(ary)]TJ +/F18 14.3462 Tf 132.314 525.468 Td [(A)-350(r)50(efer)50(enc)50(e)-350(guide)-350(for)-350(the)-350(Par)50(al)-50(lel)-350(Sp)50(arse)-350(BLAS)-350(libr)50(ary)]TJ 0 g 0 G 0 g 0 G -/F27 9.9626 Tf 223.567 -133.983 Td [(b)32(y)-383(Salv)63(atore)-383(Filipp)-32(one)]TJ 12.889 -11.956 Td [(and)-383(Alfredo)-384(Buttari)]TJ/F8 9.9626 Tf 41.655 -11.955 Td [(Dec)-333(1st,)-334(2018)]TJ +/F27 9.9626 Tf 223.567 -135.228 Td [(b)32(y)-383(Salv)63(atore)-383(Filipp)-32(one)]TJ 12.889 -11.955 Td [(and)-383(Alfredo)-384(Buttari)]TJ/F8 9.9626 Tf 41.655 -11.955 Td [(Dec)-333(1st,)-334(2018)]TJ 0 g 0 G 0 g 0 G ET @@ -553,7 +553,7 @@ BT 0 g 0 G [-913(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1083(11)]TJ + [-1083(12)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG 31.881 -12.08 Td [(get)]TJ @@ -574,7 +574,7 @@ BT 0 g 0 G [-411(.)-500(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(11)]TJ + [-1084(12)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG -40.659 -12.08 Td [(get)]TJ @@ -637,7 +637,7 @@ BT 0 g 0 G [-969(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(12)]TJ + [-1084(13)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG -46.47 -12.08 Td [(get)]TJ @@ -679,7 +679,7 @@ BT 0 g 0 G [-861(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(13)]TJ + [-1084(14)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG 0 -12.08 Td [(CNV)]TJ @@ -840,7 +840,7 @@ BT 0 g 0 G [-994(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-499(.)]TJ 0 g 0 G - [-1084(17)]TJ + [-1084(18)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG 0 -12.079 Td [(get)]TJ @@ -917,7 +917,7 @@ BT 0 g 0 G [-696(.)-500(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(18)]TJ + [-1084(19)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG -140.568 -12.08 Td [(cscn)28(v)]TJ @@ -931,7 +931,7 @@ BT 0 g 0 G [-967(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1083(19)]TJ + [-1083(20)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG 0 -12.08 Td [(clean)]TJ @@ -959,7 +959,7 @@ BT 0 g 0 G [-612(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(20)]TJ + [-1084(21)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG -16.87 -12.079 Td [(clip)]TJ @@ -1015,14 +1015,14 @@ BT 0 g 0 G [-1020(.)-500(.)-500(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(22)]TJ + [-1084(23)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG -55.149 -12.08 Td [(clone)]TJ 0 g 0 G [-361(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(22)]TJ + [-1084(23)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG -31.88 -12.08 Td [(3.2.2)-1144(Named)-334(Constan)28(ts)]TJ @@ -1071,7 +1071,7 @@ BT 0 g 0 G [-1355(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1083(24)]TJ + [-1083(25)]TJ 0 g 0 G 0 g 0 G 100.733 -29.888 Td [(i)]TJ @@ -1450,7 +1450,7 @@ BT 0 g 0 G [-668(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-499(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(25)]TJ + [-1084(26)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG -16.871 -12.08 Td [(clone)]TJ @@ -1471,7 +1471,7 @@ BT 0 g 0 G [-855(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-500(.)-499(.)-500(.)-500(.)]TJ 0 g 0 G - [-1084(26)]TJ + [-1084(27)]TJ 0 g 0 G 0 0 1 rg 0 0 1 RG /F27 9.9626 Tf -14.944 -22.126 Td [(4)-925(Computational)-383(routi)-1(n)1(es)]TJ @@ -3969,7 +3969,7 @@ endstream endobj 814 0 obj << -/Length 7702 +/Length 7719 >> stream 0 g 0 G @@ -3986,7 +3986,7 @@ BT 0 g 0 G -69.503 -22.397 Td [(7.)]TJ 0 g 0 G - [-500(Call)-333(the)-334(iterativ)28(e)-333(metho)-28(d)-333(of)-334(c)28(hoice,)-333(e.g.)]TJ/F30 9.9626 Tf 189.595 0 Td [(psb_bicgstab)]TJ/F8 9.9626 Tf -201.772 -21.778 Td [(This)-333(is)-334(the)-333(structure)-333(of)-334(the)-333(sample)-333(program)]TJ/F30 9.9626 Tf 194.328 0 Td [(test/pargen/psb_d_pde3d.f90)]TJ/F8 9.9626 Tf 141.219 0 Td [(.)]TJ -320.603 -12.573 Td [(F)83(or)-291(a)-292(sim)28(ulation)-292(in)-291(whic)27(h)-291(the)-292(same)-292(discretization)-291(mes)-1(h)-291(is)-292(used)-291(o)27(v)28(er)-292(m)28(ultiple)]TJ -14.944 -11.955 Td [(time)-333(ste)-1(p)1(s)-1(,)-333(the)-333(follo)28(wing)-334(structure)-333(ma)28(y)-333(b)-28(e)-334(more)-333(appropriate:)]TJ + [-500(Call)-333(the)-334(iterativ)28(e)-333(metho)-28(d)-333(of)-334(c)28(hoice,)-333(e.g.)]TJ/F30 9.9626 Tf 189.595 0 Td [(psb_bicgstab)]TJ/F8 9.9626 Tf -201.772 -21.778 Td [(This)-333(is)-334(the)-333(structure)-333(of)-334(the)-333(sample)-333(programs)-334(in)-333(the)-333(directory)]TJ/F30 9.9626 Tf 269.435 0 Td [(test/pargen/)]TJ/F8 9.9626 Tf 62.764 0 Td [(.)]TJ -317.255 -12.573 Td [(F)83(or)-291(a)-292(sim)28(ulation)-292(in)-291(whic)27(h)-291(the)-292(same)-292(discretization)-291(mes)-1(h)-291(is)-292(used)-291(o)27(v)28(er)-292(m)28(ultiple)]TJ -14.944 -11.955 Td [(time)-333(ste)-1(p)1(s)-1(,)-333(the)-333(follo)28(wing)-334(structure)-333(ma)28(y)-333(b)-28(e)-334(more)-333(appropriate:)]TJ 0 g 0 G 12.177 -21.779 Td [(1.)]TJ 0 g 0 G @@ -4810,142 +4810,137 @@ endstream endobj 847 0 obj << -/Length 8440 +/Length 8464 >> stream 0 g 0 G 0 g 0 G BT -/F16 14.3462 Tf 99.895 706.129 Td [(3)-1125(Data)-375(Structures)-375(and)-375(Classes)]TJ/F8 9.9626 Tf 0 -21.968 Td [(In)-369(th)1(is)-369(c)28(hapter)-369(w)28(e)-369(il)1(lustrate)-369(the)-369(d)1(ata)-369(structures)-369(u)1(s)-1(ed)-368(for)-368(de\014nition)-369(of)-368(routines)]TJ 0 -11.955 Td [(in)28(terfaces.)-796(They)-450(include)-451(data)-450(structures)-450(for)-451(sparse)-450(matrices,)-480(comm)28(unication)]TJ 0 -11.955 Td [(descriptors)-333(and)-334(precondition)1(e)-1(rs.)]TJ 14.944 -12.034 Td [(All)-319(the)-319(data)-319(t)28(yp)-28(es)-319(and)-319(the)-319(b)1(as)-1(i)1(c)-319(s)-1(u)1(broutine)-319(in)28(terface)-1(s)-318(relate)-1(d)-318(to)-319(descriptors)]TJ -14.944 -11.956 Td [(and)-445(sparse)-444(matrices)-445(are)-445(de\014ned)-445(in)-444(the)-445(mo)-28(dule)]TJ/F30 9.9626 Tf 213.082 0 Td [(psb_base_mod)]TJ/F8 9.9626 Tf 62.764 0 Td [(;)-500(this)-445(will)-445(ha)28(v)28(e)]TJ -275.846 -11.955 Td [(to)-451(b)-28(e)-451(included)-452(b)28(y)-451(ev)28(ery)-452(user)-451(subroutine)-451(that)-451(mak)27(es)-451(use)-451(of)-452(th)1(e)-452(library)84(.)-799(The)]TJ 0 -11.955 Td [(preconditioners)-333(are)-334(de\014ned)-333(in)-333(the)-334(mo)-27(dule)]TJ/F30 9.9626 Tf 184.725 0 Td [(psb_prec_mod)]TJ/F8 9.9626 Tf -169.781 -12.034 Td [(In)28(teger,)-510(real)-475(and)-475(complex)-475(data)-475(t)28(yp)-28(es)-474(are)-475(parametrized)-475(with)-475(a)-475(kind)-474(t)27(yp)-27(e)]TJ -14.944 -11.955 Td [(de\014ned)-333(in)-334(the)-333(library)-333(as)-333(follo)27(ws:)]TJ +/F16 14.3462 Tf 99.895 706.129 Td [(3)-1125(Data)-375(Structures)-375(and)-375(Classes)]TJ/F8 9.9626 Tf 0 -22.335 Td [(In)-369(th)1(is)-369(c)28(hapter)-369(w)28(e)-369(il)1(lustrate)-369(the)-369(d)1(ata)-369(structures)-369(u)1(s)-1(ed)-368(for)-368(de\014nition)-369(of)-368(routines)]TJ 0 -11.955 Td [(in)28(terfaces.)-796(They)-450(include)-451(data)-450(structures)-450(for)-451(sparse)-450(matrices,)-480(comm)28(unication)]TJ 0 -11.955 Td [(descriptors)-333(and)-334(precondition)1(e)-1(rs.)]TJ 14.944 -12.231 Td [(All)-319(the)-319(data)-319(t)28(yp)-28(es)-319(and)-319(the)-319(b)1(as)-1(i)1(c)-319(s)-1(u)1(broutine)-319(in)28(terface)-1(s)-318(relate)-1(d)-318(to)-319(descriptors)]TJ -14.944 -11.956 Td [(and)-445(sparse)-444(matrices)-445(are)-445(de\014ned)-445(in)-444(the)-445(mo)-28(dule)]TJ/F30 9.9626 Tf 213.082 0 Td [(psb_base_mod)]TJ/F8 9.9626 Tf 62.764 0 Td [(;)-500(this)-445(will)-445(ha)28(v)28(e)]TJ -275.846 -11.955 Td [(to)-451(b)-28(e)-451(included)-452(b)28(y)-451(ev)28(ery)-452(user)-451(subroutine)-451(that)-451(mak)27(es)-451(use)-451(of)-452(th)1(e)-452(library)84(.)-799(The)]TJ 0 -11.955 Td [(preconditioners)-333(are)-334(de\014ned)-333(in)-333(the)-334(mo)-27(dule)]TJ/F30 9.9626 Tf 184.725 0 Td [(psb_prec_mod)]TJ/F8 9.9626 Tf -169.781 -12.231 Td [(In)28(teger,)-510(real)-475(and)-475(complex)-475(data)-475(t)28(yp)-28(es)-474(are)-475(parametrized)-475(with)-475(a)-475(kind)-474(t)27(yp)-27(e)]TJ -14.944 -11.955 Td [(de\014ned)-333(in)-334(the)-333(library)-333(as)-333(follo)27(ws:)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -20.162 Td [(psb)]TJ +/F27 9.9626 Tf 0 -20.754 Td [(psb)]TJ ET q -1 0 0 1 117.832 568.399 cm +1 0 0 1 117.832 567.046 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 568.2 Td [(spk)]TJ +/F27 9.9626 Tf 121.269 566.847 Td [(spk)]TJ ET q -1 0 0 1 138.887 568.399 cm +1 0 0 1 138.887 567.046 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 147.306 568.2 Td [(Kind)-472(parameter)-472(for)-472(short)-472(precision)-473(real)-472(and)-472(complex)-472(data;)-542(corre-)]TJ -22.504 -11.955 Td [(sp)-28(onds)-333(to)-333(a)]TJ/F30 9.9626 Tf 53.522 0 Td [(REAL)]TJ/F8 9.9626 Tf 24.242 0 Td [(declaration)-333(and)-334(i)1(s)-334(normally)-333(4)-333(b)27(ytes;)]TJ +/F8 9.9626 Tf 147.306 566.847 Td [(Kind)-472(parameter)-472(for)-472(short)-472(precision)-473(real)-472(and)-472(complex)-472(data;)-542(corre-)]TJ -22.504 -11.955 Td [(sp)-28(onds)-333(to)-333(a)]TJ/F30 9.9626 Tf 53.522 0 Td [(REAL)]TJ/F8 9.9626 Tf 24.242 0 Td [(declaration)-333(and)-334(i)1(s)-334(normally)-333(4)-333(b)27(ytes;)]TJ 0 g 0 G -/F27 9.9626 Tf -102.671 -20.241 Td [(psb)]TJ +/F27 9.9626 Tf -102.671 -21.03 Td [(psb)]TJ ET q -1 0 0 1 117.832 536.203 cm +1 0 0 1 117.832 534.062 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 536.004 Td [(dpk)]TJ +/F27 9.9626 Tf 121.269 533.863 Td [(dpk)]TJ ET q -1 0 0 1 140.733 536.203 cm +1 0 0 1 140.733 534.062 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 149.152 536.004 Td [(Kind)-494(parameter)-495(for)-494(long)-495(precision)-494(real)-495(and)-494(complex)-495(d)1(ata;)-576(corr)1(e)-1(-)]TJ -24.35 -11.955 Td [(sp)-28(onds)-333(to)-333(a)]TJ/F30 9.9626 Tf 53.522 0 Td [(DOUBLE)-525(PRECISION)]TJ/F8 9.9626 Tf 87.006 0 Td [(declaration)-333(and)-334(is)-333(normally)-333(8)-333(b)27(ytes;)]TJ +/F8 9.9626 Tf 149.152 533.863 Td [(Kind)-494(parameter)-495(for)-494(long)-495(precision)-494(real)-495(and)-494(complex)-495(d)1(ata;)-576(corr)1(e)-1(-)]TJ -24.35 -11.956 Td [(sp)-28(onds)-333(to)-333(a)]TJ/F30 9.9626 Tf 53.522 0 Td [(DOUBLE)-525(PRECISION)]TJ/F8 9.9626 Tf 87.006 0 Td [(declaration)-333(and)-334(is)-333(normally)-333(8)-333(b)27(ytes;)]TJ 0 g 0 G -/F27 9.9626 Tf -165.435 -20.241 Td [(psb)]TJ +/F27 9.9626 Tf -165.435 -21.029 Td [(psb)]TJ ET q -1 0 0 1 117.832 504.007 cm +1 0 0 1 117.832 501.077 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 503.808 Td [(ipk)]TJ +/F27 9.9626 Tf 121.269 500.878 Td [(mpk)]TJ ET q -1 0 0 1 137.551 504.007 cm +1 0 0 1 143.916 501.077 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 145.969 503.808 Td [(Kind)-417(parameter)-416(for)-417(in)28(teger)-417(data;)-458(with)-417(default)-416(build)-417(options)-417(this)-416(is)]TJ -21.167 -11.956 Td [(a)-387(4)-387(b)28(ytes)-387(in)28(teger,)-400(but)-387(there)-387(is)-387(\050highly\051)-387(exp)-28(erimen)28(tal)-387(supp)-28(or)1(t)-387(for)-387(8-b)28(ytes)]TJ 0 -11.955 Td [(in)28(tegers;)]TJ +/F8 9.9626 Tf 152.334 500.878 Td [(Kind)-312(parameter)-311(for)-312(4-b)28(ytes)-312(in)28(teger)-312(data,)-316(as)-312(is)-312(alw)28(a)28(ys)-312(used)-312(b)28(y)-312(MPI;)]TJ 0 g 0 G -/F27 9.9626 Tf -24.907 -20.241 Td [(psb)]TJ +/F27 9.9626 Tf -52.439 -21.03 Td [(psb)]TJ ET q -1 0 0 1 117.832 459.856 cm +1 0 0 1 117.832 480.048 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 459.656 Td [(mpik)]TJ +/F27 9.9626 Tf 121.269 479.848 Td [(epk)]TJ ET q -1 0 0 1 147.098 459.856 cm +1 0 0 1 139.619 480.048 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 155.516 459.656 Td [(Kind)-282(parameter)-282(for)-282(4-b)27(ytes)-282(in)28(teger)-282(data,)-293(as)-282(is)-282(alw)28(a)27(ys)-282(used)-282(b)28(y)-282(MPI;)]TJ +/F8 9.9626 Tf 148.038 479.848 Td [(Kind)-426(parameter)-426(for)-427(8-b)28(ytes)-426(in)28(teger)-427(data,)-449(as)-426(is)-427(alw)28(a)28(ys)-426(used)-427(b)28(y)-426(the)]TJ/F30 9.9626 Tf -23.236 -11.955 Td [(sizeof)]TJ/F8 9.9626 Tf 34.703 0 Td [(metho)-28(ds;)]TJ 0 g 0 G -/F27 9.9626 Tf -55.621 -20.241 Td [(psb)]TJ +/F27 9.9626 Tf -59.61 -21.029 Td [(psb)]TJ ET q -1 0 0 1 117.832 439.615 cm +1 0 0 1 117.832 447.063 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 439.415 Td [(long)]TJ +/F27 9.9626 Tf 121.269 446.864 Td [(ipk)]TJ ET q -1 0 0 1 142.961 439.615 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 146.398 439.415 Td [(in)32(t)]TJ -ET -q -1 0 0 1 160.77 439.615 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 164.207 439.415 Td [(k)]TJ -ET -q -1 0 0 1 170.941 439.615 cm +1 0 0 1 137.551 447.063 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 179.36 439.415 Td [(Kind)-326(parameter)-326(for)-327(lon)1(g)-327(\0508)-326(b)28(ytes\051)-326(in)27(tegers,)-327(whic)27(h)-326(are)-326(alw)28(a)27(y)1(s)]TJ -54.558 -11.955 Td [(used)-333(b)27(y)-333(the)]TJ/F30 9.9626 Tf 53.743 0 Td [(sizeof)]TJ/F8 9.9626 Tf 34.703 0 Td [(metho)-28(ds.)]TJ -113.353 -20.162 Td [(T)83(ogether)-311(with)-311(the)-311(classes)-311(attributes)-311(w)28(e)-311(also)-311(discuss)-311(their)-311(metho)-28(ds.)-437(Most)-311(meth-)]TJ 0 -11.955 Td [(o)-28(ds)-342(detailed)-342(here)-342(only)-343(act)-342(on)-342(the)-342(lo)-28(cal)-342(v)55(ariable,)-344(i.e.)-471(their)-342(action)-343(i)1(s)-343(purely)-342(lo)-28(cal)]TJ 0 -11.955 Td [(and)-299(async)28(hronous)-299(unless)-298(otherwise)-299(stated.)-433(The)-299(list)-299(of)-299(metho)-27(ds)-299(here)-299(is)-299(not)-298(com)-1(-)]TJ 0 -11.955 Td [(pletely)-418(exhaustiv)27(e;)-460(man)27(y)-418(metho)-28(ds,)-439(esp)-28(ecially)-419(th)1(os)-1(e)-418(that)-418(alter)-419(th)1(e)-419(con)28(ten)28(ts)-419(of)]TJ 0 -11.955 Td [(the)-379(v)55(ariou)1(s)-380(ob)-55(jects,)-391(are)-379(usually)-379(not)-379(needed)-379(b)28(y)-379(the)-379(e)-1(n)1(d-use)-1(r)1(,)-391(and)-379(therefore)-379(are)]TJ 0 -11.956 Td [(describ)-28(ed)-333(in)-333(the)-334(dev)28(elop)-28(er's)-333(do)-28(cumen)28(tation.)]TJ/F16 11.9552 Tf 0 -28.307 Td [(3.1)-1125(Descriptor)-375(data)-375(structure)]TJ/F8 9.9626 Tf 0 -18.536 Td [(All)-349(the)-349(general)-349(matrix)-349(informations)-349(and)-349(elemen)28(ts)-349(to)-349(b)-28(e)-349(exc)28(hanged)-349(among)-349(pro-)]TJ 0 -11.955 Td [(cesses)-453(are)-453(stored)-453(within)-452(a)-453(data)-453(structure)-452(of)-453(the)-453(t)28(yp)-28(e)]TJ/F30 9.9626 Tf 242.532 0 Td [(psb)]TJ +/F8 9.9626 Tf 145.969 446.864 Td [(Kind)-470(parameter)-471(for)-470(\134lo)-28(cal")-471(in)28(teger)-470(indices)-471(and)-470(data;)-539(with)-471(default)]TJ -21.167 -11.956 Td [(build)-333(options)-333(this)-334(is)-333(a)-333(4)-334(b)28(ytes)-333(in)27(teger;)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -21.029 Td [(psb)]TJ ET q -1 0 0 1 358.746 288.923 cm +1 0 0 1 117.832 414.078 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.269 413.879 Td [(lpk)]TJ +ET +q +1 0 0 1 137.551 414.078 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +0 g 0 G +BT +/F8 9.9626 Tf 145.969 413.879 Td [(Kind)-409(parameter)-409(for)-409(\134global")-409(in)28(teger)-409(indices)-410(and)-409(data;)-447(with)-409(defaul)1(t)]TJ -21.167 -11.955 Td [(build)-333(options)-333(this)-334(is)-333(an)-333(8)-334(b)28(ytes)-333(in)28(te)-1(ger;)]TJ -24.907 -20.754 Td [(The)-378(in)27(teger)-378(kinds)-378(for)-379(lo)-28(cal)-378(and)-378(global)-379(indices)-378(can)-379(b)-27(e)-379(c)28(hosen)-378(at)-379(con\014gure)-378(time)]TJ 0 -11.955 Td [(to)-352(hold)-352(4)-352(or)-352(8)-352(b)28(ytes,)-357(with)-352(the)-352(global)-352(indices)-352(at)-352(least)-352(as)-352(large)-352(as)-352(the)-352(lo)-28(cal)-352(ones.)]TJ 0 -11.955 Td [(T)83(ogether)-311(with)-311(the)-311(classes)-311(attributes)-311(w)28(e)-311(also)-311(discuss)-311(their)-311(metho)-28(ds.)-437(Most)-311(meth-)]TJ 0 -11.955 Td [(o)-28(ds)-342(detailed)-342(here)-342(only)-343(act)-342(on)-342(the)-342(lo)-28(cal)-342(v)55(ariable,)-344(i.e.)-471(their)-342(action)-343(i)1(s)-343(purely)-342(lo)-28(cal)]TJ 0 -11.956 Td [(and)-299(async)28(hronous)-299(unless)-298(otherwise)-299(stated.)-433(The)-299(list)-299(of)-299(metho)-27(ds)-299(here)-299(is)-299(not)-298(com)-1(-)]TJ 0 -11.955 Td [(pletely)-418(exhaustiv)27(e;)-460(man)27(y)-418(metho)-28(ds,)-439(esp)-28(ecially)-419(th)1(os)-1(e)-418(that)-418(alter)-419(th)1(e)-419(con)28(ten)28(ts)-419(of)]TJ 0 -11.955 Td [(the)-379(v)55(ariou)1(s)-380(ob)-55(jects,)-391(are)-379(usually)-379(not)-379(needed)-379(b)28(y)-379(the)-379(e)-1(n)1(d-use)-1(r)1(,)-391(and)-379(therefore)-379(are)]TJ 0 -11.955 Td [(describ)-28(ed)-333(in)-333(the)-334(dev)28(elop)-28(er's)-333(do)-28(cumen)28(tation.)]TJ/F16 11.9552 Tf 0 -29.353 Td [(3.1)-1125(Descriptor)-375(data)-375(structure)]TJ/F8 9.9626 Tf 0 -18.903 Td [(All)-349(the)-349(general)-349(matrix)-349(informations)-349(and)-349(elemen)28(ts)-349(to)-349(b)-28(e)-349(exc)28(hanged)-349(among)-349(pro-)]TJ 0 -11.955 Td [(cesses)-453(are)-453(stored)-453(within)-452(a)-453(data)-453(structure)-452(of)-453(the)-453(t)28(yp)-28(e)]TJ/F30 9.9626 Tf 242.532 0 Td [(psb)]TJ +ET +q +1 0 0 1 358.746 237.472 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 361.884 288.724 Td [(desc)]TJ +/F30 9.9626 Tf 361.884 237.273 Td [(desc)]TJ ET q -1 0 0 1 383.433 288.923 cm +1 0 0 1 383.433 237.472 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 386.571 288.724 Td [(type)]TJ/F8 9.9626 Tf 20.922 0 Td [(.)-803(Ev)28(ery)]TJ -307.598 -11.955 Td [(structure)-437(of)-438(this)-437(t)28(yp)-28(e)-437(is)-438(asso)-28(ciated)-437(with)-437(a)-438(discretization)-437(pattern)-437(and)-438(enables)]TJ 0 -11.955 Td [(data)-302(comm)28(unications)-301(and)-302(other)-301(op)-28(erations)-302(that)-301(are)-302(necessary)-301(for)-302(implemen)28(ting)]TJ 0 -11.956 Td [(the)-333(v)55(arious)-333(algorithms)-333(of)-334(in)28(terest)-333(to)-334(us.)]TJ 14.944 -12.034 Td [(The)-281(data)-282(structure)-281(itself)]TJ/F30 9.9626 Tf 107.959 0 Td [(psb_desc_type)]TJ/F8 9.9626 Tf 70.797 0 Td [(can)-281(b)-28(e)-281(treate)-1(d)-281(as)-281(an)-281(opaque)-282(ob)-55(ject)]TJ -193.7 -11.955 Td [(handled)-406(via)-406(the)-406(to)-28(ols)-406(routi)1(nes)-407(of)-405(Sec)-1(.)]TJ +/F30 9.9626 Tf 386.571 237.273 Td [(type)]TJ/F8 9.9626 Tf 20.922 0 Td [(.)-803(Ev)28(ery)]TJ -307.598 -11.956 Td [(structure)-437(of)-438(this)-437(t)28(yp)-28(e)-437(is)-438(asso)-28(ciated)-437(with)-437(a)-438(discretization)-437(pattern)-437(and)-438(enables)]TJ 0 -11.955 Td [(data)-302(comm)28(unications)-301(and)-302(other)-301(op)-28(erations)-302(that)-301(are)-302(necessary)-301(for)-302(implemen)28(ting)]TJ 0 -11.955 Td [(the)-333(v)55(arious)-333(algorithms)-333(of)-334(in)28(terest)-333(to)-334(us.)]TJ 14.944 -12.231 Td [(The)-281(data)-282(structure)-281(itself)]TJ/F30 9.9626 Tf 107.959 0 Td [(psb_desc_type)]TJ/F8 9.9626 Tf 70.797 0 Td [(can)-281(b)-28(e)-281(treate)-1(d)-281(as)-281(an)-281(opaque)-282(ob)-55(ject)]TJ -193.7 -11.955 Td [(handled)-406(via)-406(the)-406(to)-28(ols)-406(routi)1(nes)-407(of)-405(Sec)-1(.)]TJ 0 0 1 rg 0 0 1 RG [-405(6)]TJ 0 g 0 G - [-406(or)-406(the)-406(query)-406(routines)-406(detailed)-406(b)-28(elo)28(w;)]TJ 0 -11.955 Td [(nev)28(ertheless)-334(w)28(e)-333(include)-334(here)-333(a)-333(description)-334(for)-333(the)-333(curious)-333(reader.)]TJ 14.944 -12.034 Td [(First)-248(w)28(e)-248(describ)-28(e)-248(t)1(he)]TJ/F30 9.9626 Tf 91.264 0 Td [(psb_indx_map)]TJ/F8 9.9626 Tf 65.233 0 Td [(t)28(yp)-28(e.)-416(This)-248(is)-248(a)-247(data)-248(structure)-248(that)-248(k)28(eeps)]TJ -171.441 -11.955 Td [(trac)28(k)-334(of)-333(a)-333(certain)-334(n)28(um)28(b)-28(er)-333(of)-333(basic)-334(issues)-333(suc)28(h)-334(as:)]TJ + [-406(or)-406(the)-406(query)-406(routines)-406(detailed)-406(b)-28(elo)28(w;)]TJ 0 -11.956 Td [(nev)28(ertheless)-334(w)28(e)-333(include)-334(here)-333(a)-333(description)-334(for)-333(the)-333(curious)-333(reader.)]TJ 14.944 -12.231 Td [(First)-248(w)28(e)-248(describ)-28(e)-248(t)1(he)]TJ/F30 9.9626 Tf 91.264 0 Td [(psb_indx_map)]TJ/F8 9.9626 Tf 65.233 0 Td [(t)28(yp)-28(e.)-416(This)-248(is)-248(a)-247(data)-248(structure)-248(that)-248(k)28(eeps)]TJ -171.441 -11.955 Td [(trac)28(k)-334(of)-333(a)-333(certain)-334(n)28(um)28(b)-28(er)-333(of)-333(basic)-334(issues)-333(suc)28(h)-334(as:)]TJ 0 g 0 G -/F14 9.9626 Tf 14.944 -20.162 Td [(\017)]TJ +/F14 9.9626 Tf 14.944 -20.753 Td [(\017)]TJ 0 g 0 G /F8 9.9626 Tf 9.963 0 Td [(The)-333(v)55(alue)-333(of)-333(the)-334(comm)28(unication/MPI)-333(con)28(te)-1(x)1(t;)]TJ -0 g 0 G -/F14 9.9626 Tf -9.963 -20.241 Td [(\017)]TJ -0 g 0 G -/F8 9.9626 Tf 9.963 0 Td [(The)-331(n)28(um)27(b)-27(er)-332(of)-331(indices)-331(in)-331(the)-332(index)-331(space,)-332(i.e.)-443(global)-332(n)28(um)28(b)-28(er)-331(of)-331(ro)28(ws)-332(and)]TJ 0 -11.955 Td [(columns)-333(of)-334(a)-333(sparse)-333(matrix;)]TJ -0 g 0 G -/F14 9.9626 Tf -9.963 -20.241 Td [(\017)]TJ -0 g 0 G -/F8 9.9626 Tf 9.963 0 Td [(The)-333(lo)-28(cal)-333(s)-1(et)-333(of)-333(indices,)-334(i)1(ncluding:)]TJ 0 g 0 G 144.458 -29.888 Td [(9)]TJ 0 g 0 G @@ -4953,7 +4948,7 @@ ET endstream endobj -857 0 obj +855 0 obj << /Length 6827 >> @@ -4962,92 +4957,100 @@ stream 0 g 0 G 0 g 0 G BT -/F27 9.9626 Tf 186.819 706.129 Td [({)]TJ +/F14 9.9626 Tf 165.649 706.129 Td [(\017)]TJ +0 g 0 G +/F8 9.9626 Tf 9.962 0 Td [(The)-331(n)27(u)1(m)27(b)-27(e)-1(r)-331(of)-331(indices)-331(in)-331(the)-332(index)-331(space,)-332(i.e.)-443(global)-332(n)28(um)28(b)-28(er)-331(of)-331(ro)27(ws)-331(and)]TJ 0 -11.955 Td [(columns)-333(of)-334(a)-333(sparse)-333(matrix;)]TJ +0 g 0 G +/F14 9.9626 Tf -9.962 -20.409 Td [(\017)]TJ +0 g 0 G +/F8 9.9626 Tf 9.962 0 Td [(The)-333(lo)-28(cal)-334(set)-333(of)-333(indices,)-334(inclu)1(ding:)]TJ +0 g 0 G +/F27 9.9626 Tf 11.208 -20.408 Td [({)]TJ 0 g 0 G /F8 9.9626 Tf 10.71 0 Td [(The)-333(n)27(um)28(b)-28(er)-333(of)-333(lo)-28(cal)-333(indices)-334(\050and)-333(lo)-28(cal)-333(ro)28(ws\051;)]TJ 0 g 0 G -/F27 9.9626 Tf -10.71 -15.622 Td [({)]TJ +/F27 9.9626 Tf -10.71 -16.182 Td [({)]TJ 0 g 0 G /F8 9.9626 Tf 10.71 0 Td [(The)-333(n)27(um)28(b)-28(er)-333(of)-333(halo)-333(indices)-334(\050and)-333(therefore)-333(lo)-28(cal)-333(c)-1(olu)1(m)-1(n)1(s)-1(\051;)]TJ 0 g 0 G -/F27 9.9626 Tf -10.71 -15.621 Td [({)]TJ +/F27 9.9626 Tf -10.71 -16.181 Td [({)]TJ 0 g 0 G -/F8 9.9626 Tf 10.71 0 Td [(The)-333(global)-334(indices)-333(corresp)-28(onding)-333(to)-333(the)-334(lo)-27(cal)-334(ones.)]TJ -46.824 -19.606 Td [(There)-376(are)-376(m)-1(an)28(y)-376(di\013eren)28(t)-376(sc)27(hemes)-376(for)-376(storing)-376(these)-377(data;)-397(therefore)-376(there)-377(are)-376(a)]TJ 0 -11.956 Td [(n)28(um)28(b)-28(er)-389(of)-389(t)28(yp)-28(es)-389(extending)-389(the)-388(base)-389(one,)-403(and)-389(the)-389(descriptor)-389(structure)-389(hold)1(s)-389(a)]TJ 0 -11.955 Td [(p)-28(olymorphic)-290(ob)-56(ject)-290(whose)-291(dyn)1(am)-1(ic)-290(t)28(yp)-28(e)-290(can)-291(b)-28(e)-290(an)28(y)-291(of)-290(the)-291(extend)1(e)-1(d)-290(t)28(yp)-28(es.)-430(The)]TJ 0 -11.955 Td [(metho)-28(ds)-333(asso)-28(ciated)-333(with)-334(this)-333(data)-333(t)28(yp)-28(e)-334(answ)28(er)-333(the)-334(f)1(ollo)27(wing)-333(queries:)]TJ +/F8 9.9626 Tf 10.71 0 Td [(The)-333(global)-334(indices)-333(corresp)-28(onding)-333(to)-333(the)-334(lo)-27(cal)-334(ones.)]TJ -46.824 -20.409 Td [(There)-376(are)-376(m)-1(an)28(y)-376(di\013eren)28(t)-376(sc)27(hemes)-376(for)-376(storing)-376(these)-377(data;)-397(therefore)-376(there)-377(are)-376(a)]TJ 0 -11.955 Td [(n)28(um)28(b)-28(er)-389(of)-389(t)28(yp)-28(es)-389(extending)-389(the)-388(base)-389(one,)-403(and)-389(the)-389(descriptor)-389(structure)-389(hold)1(s)-389(a)]TJ 0 -11.955 Td [(p)-28(olymorphic)-290(ob)-56(ject)-290(whose)-291(dyn)1(am)-1(ic)-290(t)28(yp)-28(e)-290(can)-291(b)-28(e)-290(an)28(y)-291(of)-290(the)-291(extend)1(e)-1(d)-290(t)28(yp)-28(es.)-430(The)]TJ 0 -11.955 Td [(metho)-28(ds)-333(asso)-28(ciated)-333(with)-334(this)-333(data)-333(t)28(yp)-28(e)-334(answ)28(er)-333(the)-334(f)1(ollo)27(wing)-333(queries:)]TJ 0 g 0 G -/F14 9.9626 Tf 14.944 -19.288 Td [(\017)]TJ +/F14 9.9626 Tf 14.944 -20.288 Td [(\017)]TJ 0 g 0 G /F8 9.9626 Tf 9.962 0 Td [(F)83(or)-271(a)-271(giv)28(en)-272(set)-271(of)-271(lo)-28(cal)-271(indices,)-284(\014nd)-271(the)-271(corresp)-28(onding)-271(indices)-272(in)-271(the)-271(global)]TJ 0 -11.955 Td [(n)28(um)28(b)-28(ering;)]TJ 0 g 0 G -/F14 9.9626 Tf -9.962 -19.606 Td [(\017)]TJ +/F14 9.9626 Tf -9.962 -20.408 Td [(\017)]TJ 0 g 0 G /F8 9.9626 Tf 9.962 0 Td [(F)83(or)-271(a)-271(giv)28(en)-272(set)-271(of)-271(global)-271(indices,)-284(\014nd)-271(the)-271(c)-1(or)1(re)-1(sp)-27(onding)-271(indices)-272(in)-271(the)-271(lo)-28(cal)]TJ 0 -11.955 Td [(n)28(um)28(b)-28(ering,)-333(if)-334(an)28(y)83(,)-333(or)-333(return)-333(an)-334(in)28(v)56(alid)]TJ 0 g 0 G -/F14 9.9626 Tf -9.962 -19.607 Td [(\017)]TJ +/F14 9.9626 Tf -9.962 -20.409 Td [(\017)]TJ 0 g 0 G /F8 9.9626 Tf 9.962 0 Td [(Add)-333(a)-334(global)-333(index)-333(to)-333(the)-334(set)-333(of)-334(h)1(alo)-334(indices;)]TJ 0 g 0 G -/F14 9.9626 Tf -9.962 -19.606 Td [(\017)]TJ +/F14 9.9626 Tf -9.962 -20.408 Td [(\017)]TJ 0 g 0 G -/F8 9.9626 Tf 9.962 0 Td [(Find)-333(the)-334(pro)-27(cess)-334(o)28(wner)-333(of)-334(eac)28(h)-333(mem)27(b)-27(er)-334(of)-333(a)-333(set)-334(of)-333(global)-333(indices.)]TJ -24.906 -19.288 Td [(All)-355(metho)-28(ds)-355(but)-355(the)-355(last)-355(are)-355(purely)-355(lo)-28(cal;)-366(the)-355(last)-355(metho)-28(d)-355(p)-28(oten)28(tially)-355(requires)]TJ 0 -11.955 Td [(comm)28(unication)-259(among)-258(pro)-28(cesses,)-274(and)-258(th)28(us)-259(is)-258(a)-259(sync)28(hronous)-258(m)-1(etho)-27(d.)-420(The)-258(c)27(hoice)]TJ 0 -11.955 Td [(of)-309(a)-310(sp)-28(eci\014c)-309(dynamic)-310(t)28(yp)-27(e)-310(for)-309(the)-310(index)-309(map)-310(is)-309(made)-310(at)-309(the)-309(time)-310(the)-309(descriptor)]TJ 0 -11.956 Td [(is)-333(initially)-334(al)1(lo)-28(cated,)-334(according)-333(to)-333(the)-334(mo)-27(de)-334(of)-333(initialization)-333(\050see)-334(also)]TJ +/F8 9.9626 Tf 9.962 0 Td [(Find)-333(the)-334(pro)-27(cess)-334(o)28(wner)-333(of)-334(eac)28(h)-333(mem)27(b)-27(er)-334(of)-333(a)-333(set)-334(of)-333(global)-333(indices.)]TJ -24.906 -20.288 Td [(All)-355(metho)-28(ds)-355(but)-355(the)-355(last)-355(are)-355(purely)-355(lo)-28(cal;)-366(the)-355(last)-355(metho)-28(d)-355(p)-28(oten)28(tially)-355(requires)]TJ 0 -11.955 Td [(comm)28(unication)-259(among)-258(pro)-28(cesses,)-274(and)-258(th)28(us)-259(is)-258(a)-259(sync)28(hronous)-259(metho)-27(d.)-420(The)-258(c)27(hoice)]TJ 0 -11.955 Td [(of)-309(a)-310(sp)-28(eci\014c)-309(dynamic)-310(t)28(yp)-27(e)-310(for)-309(the)-310(index)-309(map)-310(is)-309(made)-310(at)-309(the)-309(time)-310(the)-309(descriptor)]TJ 0 -11.955 Td [(is)-333(initially)-334(al)1(lo)-28(cated,)-334(according)-333(to)-333(the)-334(mo)-27(de)-334(of)-333(initialization)-333(\050see)-334(also)]TJ 0 0 1 rg 0 0 1 RG [-333(6)]TJ 0 g 0 G - [(\051.)]TJ 14.944 -11.955 Td [(The)-333(descriptor)-334(con)28(ten)28(ts)-333(are)-334(as)-333(follo)28(ws:)]TJ + [(\051.)]TJ 14.944 -12.076 Td [(The)-333(descriptor)-334(con)28(ten)28(ts)-333(are)-334(as)-333(follo)28(ws:)]TJ 0 g 0 G -/F27 9.9626 Tf -14.944 -19.287 Td [(indxmap)]TJ +/F27 9.9626 Tf -14.944 -20.288 Td [(indxmap)]TJ 0 g 0 G /F8 9.9626 Tf 48.422 0 Td [(A)-222(p)-28(olymorphic)-222(v)56(ariable)-223(of)-222(a)-222(t)28(yp)-28(e)-222(that)-222(is)-223(an)28(y)-222(extension)-222(of)-222(the)-223(indx)]TJ ET q -1 0 0 1 476.354 431.2 cm +1 0 0 1 476.354 370.98 cm []0 d 0 J 0.398 w 0 0 m 2.989 0 l S Q BT -/F8 9.9626 Tf 479.343 431.001 Td [(map)]TJ -303.732 -11.956 Td [(t)28(yp)-28(e)-333(describ)-28(ed)-333(ab)-28(o)28(v)27(e.)]TJ +/F8 9.9626 Tf 479.343 370.78 Td [(map)]TJ -303.732 -11.955 Td [(t)28(yp)-28(e)-333(describ)-28(ed)-333(ab)-28(o)28(v)27(e.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -31.561 Td [(halo)]TJ +/F27 9.9626 Tf -24.906 -32.363 Td [(halo)]TJ ET q -1 0 0 1 172.238 387.683 cm +1 0 0 1 172.238 326.661 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 175.675 387.484 Td [(index)]TJ +/F27 9.9626 Tf 175.675 326.462 Td [(index)]TJ 0 g 0 G /F8 9.9626 Tf 32.191 0 Td [(A)-384(list)-384(of)-385(the)-384(halo)-384(and)-384(b)-28(oundary)-384(elemen)28(ts)-384(for)-385(the)-384(curren)28(t)-384(pro)-28(cess)]TJ -32.255 -11.955 Td [(to)-347(b)-28(e)-347(exc)28(hanged)-347(with)-347(other)-348(p)1(ro)-28(cesses;)-354(for)-348(eac)28(h)-347(pro)-28(cesses)-347(with)-347(whic)28(h)-347(it)-347(is)]TJ 0 -11.956 Td [(necessary)-334(to)-333(comm)28(unicate:)]TJ 0 g 0 G - 9.188 -19.606 Td [(1.)]TJ + 9.188 -20.408 Td [(1.)]TJ 0 g 0 G [-500(Pro)-28(cess)-333(iden)28(ti\014er;)]TJ 0 g 0 G - 0 -15.621 Td [(2.)]TJ + 0 -16.182 Td [(2.)]TJ 0 g 0 G [-500(Num)28(b)-28(er)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(receiv)27(ed;)]TJ 0 g 0 G - 0 -15.622 Td [(3.)]TJ + 0 -16.181 Td [(3.)]TJ 0 g 0 G [-500(Indices)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(rece)-1(i)1(v)27(ed;)]TJ 0 g 0 G - 0 -15.621 Td [(4.)]TJ + 0 -16.182 Td [(4.)]TJ 0 g 0 G [-500(Num)28(b)-28(er)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(sen)27(t;)]TJ 0 g 0 G - 0 -15.622 Td [(5.)]TJ + 0 -16.182 Td [(5.)]TJ 0 g 0 G - [-500(Indices)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(sen)27(t;)]TJ -9.188 -19.606 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(v)28(ector)-334(of)-333(in)28(teger)-333(t)27(yp)-27(e,)-334(see)]TJ + [-500(Indices)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(sen)27(t;)]TJ -9.188 -20.408 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(v)28(ector)-334(of)-333(in)28(teger)-333(t)27(yp)-27(e,)-334(see)]TJ 0 0 1 rg 0 0 1 RG [-333(3.3)]TJ 0 g 0 G [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -19.607 Td [(ext)]TJ +/F27 9.9626 Tf -24.906 -20.409 Td [(ext)]TJ ET q -1 0 0 1 167.146 242.468 cm +1 0 0 1 167.146 176.799 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 170.583 242.268 Td [(index)]TJ +/F27 9.9626 Tf 170.583 176.599 Td [(index)]TJ 0 g 0 G /F8 9.9626 Tf 32.191 0 Td [(A)-274(list)-274(of)-274(elemen)28(t)-274(indices)-274(to)-273(b)-28(e)-274(exc)28(hanged)-274(to)-274(implemen)28(t)-274(the)-274(mapping)]TJ -27.163 -11.955 Td [(b)-28(et)28(w)28(een)-334(a)-333(base)-333(descriptor)-334(and)-333(a)-333(descriptor)-334(with)-333(o)28(v)28(erlap.)]TJ 0 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(v)28(ector)-334(of)-333(in)28(teger)-333(t)27(yp)-27(e,)-334(see)]TJ 0 0 1 rg 0 0 1 RG @@ -5055,71 +5058,71 @@ BT 0 g 0 G [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -19.606 Td [(o)32(vrlap)]TJ +/F27 9.9626 Tf -24.906 -20.408 Td [(o)32(vrlap)]TJ ET q -1 0 0 1 182.684 198.951 cm +1 0 0 1 182.684 132.48 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 186.122 198.752 Td [(index)]TJ +/F27 9.9626 Tf 186.122 132.281 Td [(index)]TJ 0 g 0 G -/F8 9.9626 Tf 32.191 0 Td [(A)-320(list)-320(of)-320(the)-320(o)28(v)28(erlap)-320(eleme)-1(n)28(ts)-320(for)-320(the)-320(curren)28(t)-320(pro)-28(cess,)-322(organized)]TJ -42.702 -11.956 Td [(in)-333(groups)-334(lik)28(e)-333(the)-333(previous)-334(v)28(ector:)]TJ +/F8 9.9626 Tf 32.191 0 Td [(A)-320(list)-320(of)-320(the)-320(o)28(v)28(erlap)-320(eleme)-1(n)28(ts)-320(for)-320(the)-320(curren)28(t)-320(pro)-28(cess,)-322(organized)]TJ -42.702 -11.955 Td [(in)-333(groups)-334(lik)28(e)-333(the)-333(previous)-334(v)28(ector:)]TJ 0 g 0 G - 9.188 -19.606 Td [(1.)]TJ -0 g 0 G - [-500(Pro)-28(cess)-333(iden)28(ti\014er;)]TJ -0 g 0 G - 0 -15.622 Td [(2.)]TJ -0 g 0 G - [-500(Num)28(b)-28(er)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(receiv)27(ed;)]TJ -0 g 0 G - 0 -15.621 Td [(3.)]TJ -0 g 0 G - [-500(Indices)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(rece)-1(i)1(v)27(ed;)]TJ -0 g 0 G - 0 -15.621 Td [(4.)]TJ -0 g 0 G - [-500(Num)28(b)-28(er)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(sen)27(t;)]TJ -0 g 0 G - 132.78 -29.888 Td [(10)]TJ + 141.968 -29.888 Td [(10)]TJ 0 g 0 G ET endstream endobj -870 0 obj +866 0 obj << -/Length 5421 +/Length 5178 >> stream 0 g 0 G 0 g 0 G 0 g 0 G BT -/F8 9.9626 Tf 133.99 706.129 Td [(5.)]TJ +/F8 9.9626 Tf 133.99 706.129 Td [(1.)]TJ 0 g 0 G - [-500(Indices)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(sen)27(t;)]TJ -9.188 -19.55 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(v)28(ector)-333(of)-334(in)28(teger)-333(t)27(yp)-27(e,)-334(see)]TJ + [-500(Pro)-28(cess)-333(iden)28(ti\014er;)]TJ +0 g 0 G + 0 -17.286 Td [(2.)]TJ +0 g 0 G + [-500(Num)28(b)-28(er)-333(of)-334(p)-27(oin)28(ts)-334(to)-333(b)-28(e)-333(receiv)27(ed;)]TJ +0 g 0 G + 0 -17.287 Td [(3.)]TJ +0 g 0 G + [-500(Indices)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(receiv)27(ed;)]TJ +0 g 0 G + 0 -17.286 Td [(4.)]TJ +0 g 0 G + [-500(Num)28(b)-28(er)-333(of)-334(p)-27(oin)28(ts)-334(to)-333(b)-28(e)-333(sen)27(t;)]TJ +0 g 0 G + 0 -17.286 Td [(5.)]TJ +0 g 0 G + [-500(Indices)-333(of)-334(p)-27(oin)27(ts)-333(to)-333(b)-28(e)-333(sen)27(t;)]TJ -9.188 -22.618 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(v)28(ector)-333(of)-334(in)28(teger)-333(t)27(yp)-27(e,)-334(see)]TJ 0 0 1 rg 0 0 1 RG [-333(3.3)]TJ 0 g 0 G [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.907 -19.55 Td [(o)32(vr)]TJ +/F27 9.9626 Tf -24.907 -22.617 Td [(o)32(vr)]TJ ET q -1 0 0 1 116.758 667.228 cm +1 0 0 1 116.758 591.948 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 120.195 667.029 Td [(mst)]TJ +/F27 9.9626 Tf 120.195 591.749 Td [(mst)]TJ ET q -1 0 0 1 139.405 667.228 cm +1 0 0 1 139.405 591.948 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 142.842 667.029 Td [(idx)]TJ +/F27 9.9626 Tf 142.842 591.749 Td [(idx)]TJ 0 g 0 G /F8 9.9626 Tf 20.575 0 Td [(A)-368(l)1(is)-1(t)-367(to)-368(r)1(e)-1(tri)1(e)-1(v)28(e)-367(the)-368(v)56(alue)-368(of)-367(eac)28(h)-368(o)28(v)28(erlap)-368(elemen)28(t)-368(from)-367(the)-368(re-)]TJ -38.615 -11.955 Td [(sp)-28(ectiv)28(e)-333(mas)-1(ter)-333(pro)-28(cess.)]TJ 0 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(v)28(ector)-333(of)-334(in)28(teger)-333(t)27(yp)-27(e,)-334(see)]TJ 0 0 1 rg 0 0 1 RG @@ -5127,81 +5130,57 @@ BT 0 g 0 G [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.907 -19.55 Td [(o)32(vrlap)]TJ +/F27 9.9626 Tf -24.907 -22.618 Td [(o)32(vrlap)]TJ ET q -1 0 0 1 131.875 623.768 cm +1 0 0 1 131.875 545.42 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 135.312 623.569 Td [(elem)]TJ +/F27 9.9626 Tf 135.312 545.221 Td [(elem)]TJ 0 g 0 G /F8 9.9626 Tf 28.214 0 Td [(F)83(or)-333(all)-333(o)28(v)27(erlap)-333(p)-28(oin)28(ts)-333(b)-28(elonging)-333(to)-334(th)-333(ecurren)28(t)-333(pro)-28(cess:)]TJ 0 g 0 G - -29.536 -19.55 Td [(1.)]TJ + -29.536 -22.617 Td [(1.)]TJ 0 g 0 G [-500(Ov)28(erlap)-333(p)-28(oin)28(t)-334(index;)]TJ 0 g 0 G - 0 -15.565 Td [(2.)]TJ + 0 -17.287 Td [(2.)]TJ 0 g 0 G [-500(Num)28(b)-28(er)-333(of)-334(pr)1(o)-28(cesses)-334(sharing)-333(that)-333(o)27(v)28(erlap)-333(p)-28(oin)28(ts;)]TJ 0 g 0 G - 0 -15.565 Td [(3.)]TJ + 0 -17.286 Td [(3.)]TJ 0 g 0 G - [-500(Index)-333(of)-334(a)-333(\134master")-333(pro)-28(cess:)]TJ -9.188 -19.55 Td [(Sp)-28(eci\014ed)-333(as:)-445(an)-333(allo)-28(catable)-333(in)28(teger)-333(arra)27(y)-333(of)-333(rank)-334(t)28(w)28(o.)]TJ + [-500(Index)-333(of)-334(a)-333(\134master")-333(pro)-28(cess:)]TJ -9.188 -22.617 Td [(Sp)-28(eci\014ed)-333(as:)-445(an)-333(allo)-28(catable)-333(in)28(teger)-333(arra)27(y)-333(of)-333(rank)-334(t)28(w)28(o.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.907 -19.55 Td [(bnd)]TJ +/F27 9.9626 Tf -24.907 -22.618 Td [(bnd)]TJ ET q -1 0 0 1 119.678 533.988 cm +1 0 0 1 119.678 442.996 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 123.115 533.789 Td [(elem)]TJ +/F27 9.9626 Tf 123.115 442.796 Td [(elem)]TJ 0 g 0 G -/F8 9.9626 Tf 28.213 0 Td [(A)-270(list)-269(of)-270(all)-269(b)-28(oundary)-269(p)-28(oin)28(ts,)-283(i.e.)-423(p)-28(oin)28(ts)-269(that)-270(ha)28(v)28(e)-270(a)-269(connection)-270(with)]TJ -26.526 -11.955 Td [(other)-333(pro)-28(cesses.)]TJ -24.907 -19.175 Td [(The)-450(F)83(ortran)-450(2003)-450(declaration)-450(for)]TJ/F30 9.9626 Tf 152.457 0 Td [(psb_desc_type)]TJ/F8 9.9626 Tf 72.477 0 Td [(structures)-450(is)-450(as)-450(follo)28(ws:)-678(A)]TJ +/F8 9.9626 Tf 28.213 0 Td [(A)-270(list)-269(of)-270(all)-269(b)-28(oundary)-269(p)-28(oin)28(ts,)-283(i.e.)-423(p)-28(oin)28(ts)-269(that)-270(ha)28(v)28(e)-270(a)-269(connection)-270(with)]TJ -26.526 -11.955 Td [(other)-333(pro)-28(cesses.)]TJ -24.907 -21.944 Td [(The)-450(F)83(ortran)-450(2003)-450(declaration)-450(for)]TJ/F30 9.9626 Tf 152.457 0 Td [(psb_desc_type)]TJ/F8 9.9626 Tf 72.477 0 Td [(structures)-450(is)-450(as)-450(follo)28(ws:)-678(A)]TJ 0 g 0 G 0 g 0 G 0 g 0 G 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -207.747 -19.882 Td [(type)-525(psb_desc_type)]TJ 20.921 -11.955 Td [(class\050psb_indx_map\051,)-525(allocatable)-525(::)-525(indxmap)]TJ 0 -11.955 Td [(type\050psb_i_vect_type\051)-525(::)-525(v_halo_index)]TJ 0 -11.955 Td [(type\050psb_i_vect_type\051)-525(::)-525(v_ext_index)]TJ 0 -11.955 Td [(type\050psb_i_vect_type\051)-525(::)-525(v_ovrlap_index)]TJ 0 -11.956 Td [(type\050psb_i_vect_type\051)-525(::)-525(v_ovr_mst_idx)]TJ 0 -11.955 Td [(integer,)-525(allocatable)-1050(::)-525(ovrlap_elem\050:,:\051)]TJ 0 -11.955 Td [(integer,)-525(allocatable)-1050(::)-525(bnd_elem\050:\051)]TJ -20.921 -11.955 Td [(end)-525(type)-525(psb_desc_type)]TJ/F8 9.9626 Tf -17.187 -30.054 Td [(Figure)-464(3:)-705(The)-464(PSBLAS)-464(de\014ned)-464(data)-464(t)28(yp)-28(e)-464(that)-463(con)27(tains)-464(th)1(e)-464(com)-1(m)28(unication)]TJ 0 -11.955 Td [(descriptor.)]TJ +/F30 9.9626 Tf -207.747 -21.604 Td [(type)-525(psb_desc_type)]TJ 20.921 -11.955 Td [(class\050psb_indx_map\051,)-525(allocatable)-525(::)-525(indxmap)]TJ 0 -11.955 Td [(type\050psb_i_vect_type\051)-525(::)-525(v_halo_index)]TJ 0 -11.955 Td [(type\050psb_i_vect_type\051)-525(::)-525(v_ext_index)]TJ 0 -11.955 Td [(type\050psb_i_vect_type\051)-525(::)-525(v_ovrlap_index)]TJ 0 -11.956 Td [(type\050psb_i_vect_type\051)-525(::)-525(v_ovr_mst_idx)]TJ 0 -11.955 Td [(integer,)-525(allocatable)-1050(::)-525(ovrlap_elem\050:,:\051)]TJ 0 -11.955 Td [(integer,)-525(allocatable)-1050(::)-525(bnd_elem\050:\051)]TJ -20.921 -11.955 Td [(end)-525(type)-525(psb_desc_type)]TJ/F8 9.9626 Tf -17.187 -30.054 Td [(Figure)-464(3:)-705(The)-464(PSBLAS)-464(de\014ned)-464(data)-464(t)28(yp)-28(e)-464(that)-463(con)27(tains)-464(th)1(e)-464(com)-1(m)28(unication)]TJ 0 -11.955 Td [(descriptor.)]TJ 0 g 0 G - 0 -23.259 Td [(comm)28(unication)-415(desc)-1(ri)1(ptor)-416(asso)-27(ciate)-1(d)-415(with)-415(a)-415(sparse)-415(matrix)-415(has)-416(a)-415(state,)-435(whic)27(h)]TJ 0 -11.955 Td [(can)-333(tak)27(e)-333(the)-333(follo)28(wing)-334(v)56(alues:)]TJ + 0 -24.98 Td [(comm)28(unication)-415(desc)-1(ri)1(ptor)-416(asso)-27(ciate)-1(d)-415(with)-415(a)-415(sparse)-415(matrix)-415(has)-416(a)-415(state,)-435(whic)27(h)]TJ 0 -11.955 Td [(can)-333(tak)27(e)-333(the)-333(follo)28(wing)-334(v)56(alues:)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -19.174 Td [(Build:)]TJ +/F27 9.9626 Tf 0 -21.944 Td [(Build:)]TJ 0 g 0 G /F8 9.9626 Tf 35.409 0 Td [(State)-306(en)28(tered)-306(after)-307(the)-306(\014rst)-306(allo)-28(cation,)-311(and)-306(b)-28(efore)-306(the)-306(\014rst)-306(assem)27(bly;)-315(in)]TJ -10.502 -11.956 Td [(this)-224(state)-223(it)-224(is)-223(p)-28(ossible)-224(to)-223(add)-224(comm)28(unication)-224(requiremen)28(ts)-224(among)-223(di\013eren)27(t)]TJ 0 -11.955 Td [(pro)-28(cesses.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.907 -19.55 Td [(Assem)32(bled:)]TJ +/F27 9.9626 Tf -24.907 -22.617 Td [(Assem)32(bled:)]TJ 0 g 0 G -/F8 9.9626 Tf 61.508 0 Td [(State)-351(en)28(tered)-351(after)-351(the)-350(assem)27(bly;)-359(computations)-351(using)-351(the)-350(ass)-1(o)-27(ci-)]TJ -36.601 -11.955 Td [(ated)-392(sparse)-391(matrix,)-406(suc)28(h)-392(as)-391(m)-1(atr)1(ix-v)27(ector)-391(pro)-28(ducts,)-406(are)-392(only)-391(p)-28(ossible)-391(in)]TJ 0 -11.955 Td [(this)-333(state.)]TJ/F27 9.9626 Tf -24.907 -25.734 Td [(3.1.1)-1150(Descriptor)-384(Metho)-31(ds)]TJ 0 -18.39 Td [(get)]TJ -ET -q -1 0 0 1 116.018 179.444 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 119.455 179.244 Td [(lo)-32(cal)]TJ -ET -q -1 0 0 1 143.215 179.444 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 146.653 179.244 Td [(ro)32(ws)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(lo)-32(cal)-383(ro)32(ws)]TJ +/F8 9.9626 Tf 61.508 0 Td [(State)-351(en)28(tered)-351(after)-351(the)-350(assem)27(bly;)-359(computations)-351(using)-351(the)-350(ass)-1(o)-27(ci-)]TJ -36.601 -11.955 Td [(ated)-392(sparse)-391(matrix,)-406(suc)28(h)-392(as)-391(m)-1(atr)1(ix-v)27(ector)-391(pro)-28(ducts,)-406(are)-392(only)-391(p)-28(ossible)-391(in)]TJ 0 -11.955 Td [(this)-333(state.)]TJ 0 g 0 G -0 g 0 G -/F30 9.9626 Tf -46.758 -18.389 Td [(nr)-525(=)-525(desc%get_local_rows\050\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -20.979 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.55 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G -/F8 9.9626 Tf 166.875 -29.888 Td [(11)]TJ + 141.968 -29.888 Td [(11)]TJ 0 g 0 G ET @@ -5209,127 +5188,128 @@ endstream endobj 881 0 obj << -/Length 5152 +/Length 5199 >> stream 0 g 0 G 0 g 0 G -0 g 0 G BT -/F27 9.9626 Tf 150.705 706.129 Td [(desc)]TJ +/F27 9.9626 Tf 150.705 706.129 Td [(3.1.1)-1150(Descriptor)-384(M)1(etho)-32(ds)]TJ 0 -18.549 Td [(get)]TJ +ET +q +1 0 0 1 166.827 687.78 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 170.264 687.58 Td [(lo)-32(cal)]TJ +ET +q +1 0 0 1 194.025 687.78 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 197.462 687.58 Td [(ro)32(ws)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(lo)-32(cal)-383(ro)32(ws)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -46.757 -18.548 Td [(nr)-525(=)-525(desc%get_local_rows\050\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -22.174 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -20.267 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -20.267 Td [(desc)]TJ 0 g 0 G /F8 9.9626 Tf 26.208 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -80.358 -34.653 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -80.358 -34.13 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -20.964 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -20.267 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G /F8 9.9626 Tf 78.386 0 Td [(The)-460(n)28(um)27(b)-27(er)-461(of)-460(lo)-28(cal)-460(ro)28(ws,)-492(i.e.)-825(the)-460(n)28(um)27(b)-27(er)-461(of)-460(ro)28(ws)-460(o)28(wned)]TJ -53.48 -11.955 Td [(b)28(y)-401(the)-401(curren)27(t)-401(pro)-27(ces)-1(s;)-435(as)-401(explained)-401(in)]TJ 0 0 1 rg 0 0 1 RG [-401(1)]TJ 0 g 0 G - [(,)-418(it)-401(is)-401(equal)-401(to)]TJ/F14 9.9626 Tf 249.678 0 Td [(jI)]TJ/F10 6.9738 Tf 8.192 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 5.431 0 Td [(+)]TJ/F14 9.9626 Tf 10.413 0 Td [(jB)]TJ/F10 6.9738 Tf 9.311 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 2.767 0 Td [(.)-648(The)]TJ -292.426 -11.956 Td [(returned)-333(v)55(alue)-333(is)-333(sp)-28(eci\014c)-334(to)-333(the)-333(calling)-334(p)1(ro)-28(cess.)]TJ/F27 9.9626 Tf -24.906 -27.274 Td [(get)]TJ + [(,)-418(it)-401(is)-401(equal)-401(to)]TJ/F14 9.9626 Tf 249.678 0 Td [(jI)]TJ/F10 6.9738 Tf 8.192 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 5.431 0 Td [(+)]TJ/F14 9.9626 Tf 10.413 0 Td [(jB)]TJ/F10 6.9738 Tf 9.311 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 2.767 0 Td [(.)-648(The)]TJ -292.426 -11.955 Td [(returned)-333(v)55(alue)-333(is)-333(sp)-28(eci\014c)-334(to)-333(the)-333(calling)-334(p)1(ro)-28(cess.)]TJ/F27 9.9626 Tf -24.906 -26.35 Td [(get)]TJ ET q -1 0 0 1 166.827 587.571 cm +1 0 0 1 166.827 489.912 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 170.264 587.372 Td [(lo)-32(cal)]TJ +/F27 9.9626 Tf 170.264 489.712 Td [(lo)-32(cal)]TJ ET q -1 0 0 1 194.025 587.571 cm +1 0 0 1 194.025 489.912 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 197.462 587.372 Td [(cols)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(lo)-32(cal)-383(cols)]TJ +/F27 9.9626 Tf 197.462 489.712 Td [(cols)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(lo)-32(cal)-383(cols)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -46.757 -18.873 Td [(nc)-525(=)-525(desc%get_local_cols\050\051)]TJ +/F30 9.9626 Tf -46.757 -18.548 Td [(nc)-525(=)-525(desc%get_local_cols\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -22.697 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -22.174 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -20.965 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -20.267 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -20.964 Td [(desc)]TJ + 0 -20.267 Td [(desc)]TJ 0 g 0 G -/F8 9.9626 Tf 26.208 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +/F8 9.9626 Tf 26.208 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -80.358 -34.653 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -80.358 -34.129 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -20.964 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -20.267 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G /F8 9.9626 Tf 78.386 0 Td [(The)-361(n)28(um)28(b)-28(er)-360(of)-361(lo)-27(cal)-361(cols,)-367(i.e.)-526(the)-361(n)28(um)28(b)-28(er)-360(of)-361(indices)-360(used)-361(b)28(y)]TJ -53.48 -11.955 Td [(the)-421(curren)28(t)-421(pro)-28(cess,)-443(including)-421(b)-27(oth)-421(lo)-28(cal)-421(and)-421(halo)-421(ind)1(ice)-1(s;)-464(as)-421(explained)]TJ 0 -11.955 Td [(in)]TJ 0 0 1 rg 0 0 1 RG [-344(1)]TJ 0 g 0 G - [(,)-346(it)-343(is)-344(equal)-343(to)]TJ/F14 9.9626 Tf 81.777 0 Td [(jI)]TJ/F10 6.9738 Tf 8.192 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 5.049 0 Td [(+)]TJ/F14 9.9626 Tf 10.031 0 Td [(jB)]TJ/F10 6.9738 Tf 9.311 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 5.049 0 Td [(+)]TJ/F14 9.9626 Tf 10.03 0 Td [(jH)]TJ/F10 6.9738 Tf 11.181 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 2.768 0 Td [(.)-475(The)-344(returned)-343(v)55(al)1(ue)-344(is)-344(sp)-27(ec)-1(i)1(\014c)-344(to)-344(the)]TJ -153.339 -11.956 Td [(calling)-333(pro)-28(cess.)]TJ/F27 9.9626 Tf -24.906 -27.274 Td [(get)]TJ + [(,)-346(it)-343(is)-344(equal)-343(to)]TJ/F14 9.9626 Tf 81.777 0 Td [(jI)]TJ/F10 6.9738 Tf 8.192 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 5.049 0 Td [(+)]TJ/F14 9.9626 Tf 10.031 0 Td [(jB)]TJ/F10 6.9738 Tf 9.311 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 5.049 0 Td [(+)]TJ/F14 9.9626 Tf 10.03 0 Td [(jH)]TJ/F10 6.9738 Tf 11.181 -1.495 Td [(i)]TJ/F14 9.9626 Tf 3.317 1.495 Td [(j)]TJ/F8 9.9626 Tf 2.768 0 Td [(.)-475(The)-344(returned)-343(v)55(al)1(ue)-344(is)-344(sp)-27(ec)-1(i)1(\014c)-344(to)-344(the)]TJ -153.339 -11.956 Td [(calling)-333(pro)-28(cess.)]TJ/F27 9.9626 Tf -24.906 -26.349 Td [(get)]TJ ET q -1 0 0 1 166.827 373.36 cm +1 0 0 1 166.827 280.088 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 170.264 373.161 Td [(global)]TJ +/F27 9.9626 Tf 170.264 279.889 Td [(global)]TJ ET q -1 0 0 1 200.708 373.36 cm +1 0 0 1 200.708 280.088 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 204.145 373.161 Td [(ro)32(ws)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(global)-383(ro)32(ws)]TJ +/F27 9.9626 Tf 204.145 279.889 Td [(ro)32(ws)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(global)-383(ro)32(ws)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -53.44 -18.873 Td [(nr)-525(=)-525(desc%get_global_rows\050\051)]TJ +/F30 9.9626 Tf -53.44 -18.548 Td [(nr)-525(=)-525(desc%get_global_rows\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -22.697 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -22.174 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -20.965 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -20.267 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -20.964 Td [(desc)]TJ + 0 -20.268 Td [(desc)]TJ 0 g 0 G /F8 9.9626 Tf 26.208 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -80.358 -34.653 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -80.358 -34.129 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -20.964 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -20.267 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(The)-390(n)28(um)27(b)-27(er)-391(of)-390(global)-390(ro)28(ws,)-405(i.e.)-615(the)-390(size)-391(of)-390(the)-390(global)-390(index)]TJ -53.48 -11.955 Td [(space.)]TJ/F27 9.9626 Tf -24.906 -27.275 Td [(get)]TJ -ET -q -1 0 0 1 166.827 183.06 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 170.264 182.86 Td [(global)]TJ -ET -q -1 0 0 1 200.708 183.06 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 204.145 182.86 Td [(cols)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(global)-383(cols)]TJ +/F8 9.9626 Tf 78.386 0 Td [(The)-390(n)28(um)27(b)-27(er)-391(of)-390(global)-390(ro)28(ws,)-405(i.e.)-615(the)-390(size)-391(of)-390(the)-390(global)-390(index)]TJ -53.48 -11.955 Td [(space.)]TJ 0 g 0 G -0 g 0 G -/F30 9.9626 Tf -53.44 -18.873 Td [(nr)-525(=)-525(desc%get_global_cols\050\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -22.697 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -20.964 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G -/F8 9.9626 Tf 166.874 -29.888 Td [(12)]TJ + 141.968 -29.888 Td [(12)]TJ 0 g 0 G ET @@ -5337,102 +5317,117 @@ endstream endobj 885 0 obj << -/Length 4083 +/Length 4312 >> stream 0 g 0 G 0 g 0 G -0 g 0 G BT -/F27 9.9626 Tf 99.895 706.129 Td [(desc)]TJ -0 g 0 G -/F8 9.9626 Tf 26.209 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.359 -33.74 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -19.872 Td [(F)96(unction)-384(v)64(alue)]TJ -0 g 0 G -/F8 9.9626 Tf 78.387 0 Td [(The)-273(n)28(um)28(b)-28(er)-273(of)-272(global)-273(cols;)-293(usually)-273(this)-273(is)-272(e)-1(q)1(ual)-273(to)-273(the)-273(n)28(um)28(b)-28(er)]TJ -53.48 -11.955 Td [(of)-333(global)-334(ro)28(ws.)]TJ/F27 9.9626 Tf -24.907 -25.873 Td [(get)]TJ +/F27 9.9626 Tf 99.895 706.129 Td [(get)]TJ ET q -1 0 0 1 116.018 602.933 cm +1 0 0 1 116.018 706.328 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 119.455 602.734 Td [(global)]TJ +/F27 9.9626 Tf 119.455 706.129 Td [(global)]TJ ET q -1 0 0 1 149.899 602.933 cm +1 0 0 1 149.899 706.328 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 153.336 602.734 Td [(indices)-383(|)-384(Get)-383(v)32(ector)-383(of)-384(global)-383(indices)]TJ +/F27 9.9626 Tf 153.336 706.129 Td [(cols)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(global)-383(cols)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -53.441 -18.389 Td [(myidx)-525(=)-525(desc%get_global_indices\050[owned]\051)]TJ +/F30 9.9626 Tf -53.441 -18.505 Td [(nr)-525(=)-525(desc%get_global_cols\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -21.785 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -22.105 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -19.872 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -20.175 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -19.872 Td [(desc)]TJ + 0 -20.174 Td [(desc)]TJ +0 g 0 G +/F8 9.9626 Tf 26.209 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.359 -34.06 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -20.174 Td [(F)96(unction)-384(v)64(alue)]TJ +0 g 0 G +/F8 9.9626 Tf 78.387 0 Td [(The)-273(n)28(um)28(b)-28(er)-273(of)-272(global)-273(cols;)-293(usually)-273(this)-273(is)-272(e)-1(q)1(ual)-273(to)-273(the)-273(n)28(um)28(b)-28(er)]TJ -53.48 -11.956 Td [(of)-333(global)-334(ro)28(ws.)]TJ/F27 9.9626 Tf -24.907 -26.226 Td [(get)]TJ +ET +q +1 0 0 1 116.018 520.998 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 119.455 520.799 Td [(global)]TJ +ET +q +1 0 0 1 149.899 520.998 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 153.336 520.799 Td [(indices)-383(|)-384(Get)-383(v)32(ector)-383(of)-384(global)-383(indices)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -53.441 -18.505 Td [(myidx)-525(=)-525(desc%get_global_indices\050[owned]\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -22.105 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -20.174 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -20.175 Td [(desc)]TJ 0 g 0 G /F8 9.9626 Tf 26.209 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -55.452 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf 41.898 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -96.416 -31.827 Td [(o)32(wned)]TJ +/F27 9.9626 Tf -96.416 -32.13 Td [(o)32(wned)]TJ 0 g 0 G -/F8 9.9626 Tf 36.647 0 Td [(Cho)-28(ose)-439(if)-439(y)28(ou)-439(only)-439(w)27(an)28(t)-439(o)28(wned)-439(indices)-439(\050)]TJ/F30 9.9626 Tf 183.494 0 Td [(owned=.true.)]TJ/F8 9.9626 Tf 62.764 0 Td [(\051)-439(or)-439(also)-439(halo)]TJ -257.998 -11.955 Td [(indices)-333(\050)]TJ/F30 9.9626 Tf 36.585 0 Td [(owned=.false.)]TJ/F8 9.9626 Tf 67.994 0 Td [(\051.)-444(Scop)-28(e:)]TJ/F27 9.9626 Tf 43.449 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -171.101 -11.956 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(optional)]TJ/F8 9.9626 Tf 40.577 0 Td [(;)-333(default:)]TJ/F30 9.9626 Tf 43.448 0 Td [(.true.)]TJ/F8 9.9626 Tf 31.382 0 Td [(.)]TJ +/F8 9.9626 Tf 36.647 0 Td [(Cho)-28(ose)-439(if)-439(y)28(ou)-439(only)-439(w)27(an)28(t)-439(o)28(wned)-439(indices)-439(\050)]TJ/F30 9.9626 Tf 183.494 0 Td [(owned=.true.)]TJ/F8 9.9626 Tf 62.764 0 Td [(\051)-439(or)-439(also)-439(halo)]TJ -257.998 -11.955 Td [(indices)-333(\050)]TJ/F30 9.9626 Tf 36.585 0 Td [(owned=.false.)]TJ/F8 9.9626 Tf 67.994 0 Td [(\051.)-444(Scop)-28(e:)]TJ/F27 9.9626 Tf 43.449 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -171.101 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(optional)]TJ/F8 9.9626 Tf 40.577 0 Td [(;)-333(default:)]TJ/F30 9.9626 Tf 43.448 0 Td [(.true.)]TJ/F8 9.9626 Tf 31.382 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -169.925 -33.739 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -169.925 -34.06 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -19.872 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -20.174 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G -/F8 9.9626 Tf 78.387 0 Td [(The)-292(global)-292(ind)1(ice)-1(s,)-300(returned)-291(as)-292(an)-292(allo)-28(catable)-292(in)28(teger)-292(arra)28(y)-292(of)]TJ -53.48 -11.955 Td [(rank)-333(1.)]TJ/F27 9.9626 Tf -24.907 -25.873 Td [(get)]TJ +/F8 9.9626 Tf 78.387 0 Td [(The)-292(global)-292(ind)1(ice)-1(s,)-300(returned)-291(as)-292(an)-292(allo)-28(catable)-292(in)28(teger)-292(arra)28(y)-292(of)]TJ -53.48 -11.956 Td [(rank)-333(1.)]TJ/F27 9.9626 Tf -24.907 -26.226 Td [(get)]TJ ET q -1 0 0 1 116.018 351.928 cm +1 0 0 1 116.018 267.673 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 119.455 351.729 Td [(con)32(text)-383(|)-384(Get)-383(comm)32(unication)-384(con)32(text)]TJ +/F27 9.9626 Tf 119.455 267.474 Td [(con)32(text)-383(|)-384(Get)-383(comm)32(unication)-384(con)32(text)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -19.56 -18.39 Td [(ictxt)-525(=)-525(desc%get_context\050\051)]TJ +/F30 9.9626 Tf -19.56 -18.505 Td [(ictxt)-525(=)-525(desc%get_context\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -21.784 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -22.105 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -19.872 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -20.174 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -19.872 Td [(desc)]TJ + 0 -20.175 Td [(desc)]TJ 0 g 0 G /F8 9.9626 Tf 26.209 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -80.359 -33.74 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -80.359 -34.06 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -19.872 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -20.174 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G -/F8 9.9626 Tf 78.387 0 Td [(The)-333(comm)27(unication)-333(con)28(text.)]TJ/F27 9.9626 Tf -78.387 -25.873 Td [(Clone)-383(|)-384(clone)-383(curren)32(t)-383(ob)-64(ject)]TJ +/F8 9.9626 Tf 78.387 0 Td [(The)-333(comm)27(unication)-333(con)28(text.)]TJ 0 g 0 G -0 g 0 G -/F30 9.9626 Tf 0 -18.389 Td [(call)-1050(desc%clone\050descout,info\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -21.784 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.872 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G -/F8 9.9626 Tf 166.875 -29.888 Td [(13)]TJ + 88.488 -29.888 Td [(13)]TJ 0 g 0 G ET @@ -5440,159 +5435,166 @@ endstream endobj 890 0 obj << -/Length 5794 +/Length 4851 >> stream 0 g 0 G 0 g 0 G -0 g 0 G BT -/F27 9.9626 Tf 150.705 706.129 Td [(desc)]TJ -0 g 0 G -/F8 9.9626 Tf 26.208 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.358 -31.376 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf 150.705 706.129 Td [(Clone)-383(|)-384(clone)-383(curren)32(t)-383(ob)-64(ject)]TJ 0 g 0 G 0 g 0 G - 0 -18.927 Td [(descout)]TJ +/F30 9.9626 Tf 0 -18.844 Td [(call)-1050(desc%clone\050descout,info\051)]TJ 0 g 0 G -/F8 9.9626 Tf 42.757 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-334(in)1(put)-334(ob)-55(ject.)]TJ -0 g 0 G -/F27 9.9626 Tf -42.757 -18.927 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -25.465 Td [(CNV)-383(|)-384(con)32(v)32(ert)-383(in)32(ternal)-384(storage)-383(format)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 0 -18.39 Td [(call)-1050(desc%cnv\050mold\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -19.421 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -22.65 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -18.926 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -20.902 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -18.927 Td [(desc)]TJ + 0 -20.902 Td [(desc)]TJ +0 g 0 G +/F8 9.9626 Tf 26.208 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.358 -34.605 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -20.902 Td [(descout)]TJ +0 g 0 G +/F8 9.9626 Tf 42.757 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-334(in)1(put)-334(ob)-55(ject.)]TJ +0 g 0 G +/F27 9.9626 Tf -42.757 -20.902 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -27.192 Td [(CNV)-383(|)-384(con)32(v)32(ert)-383(in)32(ternal)-384(storage)-383(format)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 0 -18.844 Td [(call)-1050(desc%cnv\050mold\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -22.65 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -20.902 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -20.902 Td [(desc)]TJ 0 g 0 G /F8 9.9626 Tf 26.208 0 Td [(the)-333(comm)27(unication)-333(descriptor.)]TJ -1.302 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -80.358 -30.882 Td [(mold)]TJ +/F27 9.9626 Tf -80.358 -32.858 Td [(mold)]TJ 0 g 0 G /F8 9.9626 Tf 29.805 0 Td [(the)-333(desred)-334(in)28(teger)-333(storage)-334(format.)]TJ -4.899 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -55.452 -11.955 Td [(Sp)-28(eci\014ed)-222(as:)-389(a)-222(ob)-56(ject)-222(of)-222(t)28(yp)-28(e)-222(deriv)28(e)-1(d)-222(from)-222(\050in)28(teger\051)]TJ/F30 9.9626 Tf 219.871 0 Td [(psb)]TJ ET q -1 0 0 1 411.8 457.267 cm +1 0 0 1 411.8 355.452 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 414.939 457.068 Td [(T)]TJ +/F30 9.9626 Tf 414.939 355.253 Td [(T)]TJ ET q -1 0 0 1 420.797 457.267 cm +1 0 0 1 420.797 355.452 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 423.935 457.068 Td [(base)]TJ +/F30 9.9626 Tf 423.935 355.253 Td [(base)]TJ ET q -1 0 0 1 445.484 457.267 cm +1 0 0 1 445.484 355.452 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 448.622 457.068 Td [(vect)]TJ +/F30 9.9626 Tf 448.622 355.253 Td [(vect)]TJ ET q -1 0 0 1 470.171 457.267 cm +1 0 0 1 470.171 355.452 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 473.309 457.068 Td [(type)]TJ/F8 9.9626 Tf 20.922 0 Td [(.)]TJ -343.526 -19.421 Td [(The)]TJ/F30 9.9626 Tf 20.085 0 Td [(mold)]TJ/F8 9.9626 Tf 23.848 0 Td [(argumen)28(ts)-294(ma)28(y)-294(b)-28(e)-294(emplo)28(y)28(ed)-294(to)-294(in)28(terface)-294(with)-293(sp)-28(ecial)-294(devices,)-302(suc)28(h)-294(as)]TJ -43.933 -11.955 Td [(GPUs)-333(and)-334(other)-333(accelerators.)]TJ/F27 9.9626 Tf 0 -25.466 Td [(psb)]TJ +/F30 9.9626 Tf 473.309 355.253 Td [(type)]TJ/F8 9.9626 Tf 20.922 0 Td [(.)]TJ -343.526 -22.895 Td [(The)]TJ/F30 9.9626 Tf 20.085 0 Td [(mold)]TJ/F8 9.9626 Tf 23.848 0 Td [(argumen)28(ts)-294(ma)28(y)-294(b)-28(e)-294(emplo)28(y)28(ed)-294(to)-294(in)28(terface)-294(with)-293(sp)-28(ecial)-294(devices,)-302(suc)28(h)-294(as)]TJ -43.933 -11.955 Td [(GPUs)-333(and)-334(other)-333(accelerators.)]TJ/F27 9.9626 Tf 0 -27.191 Td [(psb)]TJ ET q -1 0 0 1 168.641 400.425 cm +1 0 0 1 168.641 293.411 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 172.078 400.226 Td [(cd)]TJ +/F27 9.9626 Tf 172.078 293.212 Td [(cd)]TJ ET q -1 0 0 1 184.223 400.425 cm +1 0 0 1 184.223 293.411 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 187.66 400.226 Td [(get)]TJ +/F27 9.9626 Tf 187.66 293.212 Td [(get)]TJ ET q -1 0 0 1 203.782 400.425 cm +1 0 0 1 203.782 293.411 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 207.22 400.226 Td [(large)]TJ +/F27 9.9626 Tf 207.22 293.212 Td [(large)]TJ ET q -1 0 0 1 232.357 400.425 cm +1 0 0 1 232.357 293.411 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 235.794 400.226 Td [(threshold)-268(|)-268(Get)-268(threshold)-269(for)-268(index)-268(mapping)-268(switc)32(h)]TJ +/F27 9.9626 Tf 235.794 293.212 Td [(threshold)-268(|)-268(Get)-268(threshold)-269(for)-268(index)-268(mapping)-268(switc)32(h)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -85.089 -18.39 Td [(ith)-525(=)-525(psb_cd_get_large_threshold\050\051)]TJ +/F30 9.9626 Tf -85.089 -18.844 Td [(ith)-525(=)-525(psb_cd_get_large_threshold\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -19.421 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -22.65 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -18.926 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -33.797 -20.902 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -18.927 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -20.903 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(The)-333(curren)27(t)-333(v)56(alue)-334(for)-333(the)-333(size)-334(threshold.)]TJ/F27 9.9626 Tf -78.386 -25.466 Td [(psb)]TJ +/F8 9.9626 Tf 78.386 0 Td [(The)-333(curren)27(t)-333(v)56(alue)-334(for)-333(the)-333(size)-334(threshold.)]TJ/F27 9.9626 Tf -78.386 -27.191 Td [(psb)]TJ ET q -1 0 0 1 168.641 299.296 cm +1 0 0 1 168.641 182.921 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 172.078 299.096 Td [(cd)]TJ +/F27 9.9626 Tf 172.078 182.722 Td [(cd)]TJ ET q -1 0 0 1 184.223 299.296 cm +1 0 0 1 184.223 182.921 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 187.66 299.096 Td [(set)]TJ +/F27 9.9626 Tf 187.66 182.722 Td [(set)]TJ ET q -1 0 0 1 202.573 299.296 cm +1 0 0 1 202.573 182.921 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 206.01 299.096 Td [(large)]TJ +/F27 9.9626 Tf 206.01 182.722 Td [(large)]TJ ET q -1 0 0 1 231.147 299.296 cm +1 0 0 1 231.147 182.921 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 234.585 299.096 Td [(threshold)-323(|)-324(Set)-323(threshold)-323(for)-324(index)-323(mapping)-324(switc)32(h)]TJ +/F27 9.9626 Tf 234.585 182.722 Td [(threshold)-323(|)-324(Set)-323(threshold)-323(for)-324(index)-323(mapping)-324(switc)32(h)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -83.88 -18.389 Td [(call)-525(psb_cd_set_large_threshold\050ith\051)]TJ +/F30 9.9626 Tf -83.88 -18.844 Td [(call)-525(psb_cd_set_large_threshold\050ith\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -19.421 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -22.65 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Sync)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -18.927 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -20.902 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -18.926 Td [(ith)]TJ -0 g 0 G -/F8 9.9626 Tf 18.984 0 Td [(the)-333(new)-334(threshold)-333(for)-333(comm)27(un)1(ic)-1(ati)1(on)-334(descriptors.)]TJ 5.923 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.378 0 Td [(global)]TJ/F8 9.9626 Tf 29.756 0 Td [(.)]TJ -62.135 -11.956 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(required)]TJ/F8 9.9626 Tf 41.898 0 Td [(.)]TJ -71.51 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.548 0 Td [(.)]TJ -43.034 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(an)-333(in)28(teger)-333(v)55(alue)-333(greater)-334(th)1(an)-334(zero.)]TJ -24.906 -19.421 Td [(Note:)-756(the)-490(thr)1(e)-1(shold)-489(v)56(alue)-489(is)-490(only)-489(queried)-489(b)28(y)-489(the)-490(library)-489(at)-489(the)-489(time)-490(a)-489(call)]TJ 0 -11.955 Td [(to)]TJ/F30 9.9626 Tf 13.431 0 Td [(psb_cdall)]TJ/F8 9.9626 Tf 51.648 0 Td [(is)-459(executed,)-491(therefore)-459(c)27(hanging)-459(the)-459(threshold)-459(has)-459(no)-460(e\013ect)-459(on)]TJ -65.079 -11.955 Td [(comm)28(unication)-464(descriptors)-465(that)-464(ha)28(v)28(e)-464(already)-464(b)-28(een)-464(initialized.)-837(Moreo)28(v)27(er)-464(the)]TJ 0 -11.955 Td [(threshold)-333(m)28(ust)-334(ha)28(v)28(e)-334(the)-333(same)-333(v)55(alue)-333(on)-333(all)-334(pro)-27(ce)-1(sses.)]TJ -0 g 0 G - 166.874 -29.888 Td [(14)]TJ +/F8 9.9626 Tf 166.874 -29.888 Td [(14)]TJ 0 g 0 G ET @@ -5600,225 +5602,228 @@ endstream endobj 898 0 obj << -/Length 9961 +/Length 9583 >> stream 0 g 0 G 0 g 0 G -BT -/F27 9.9626 Tf 99.895 706.129 Td [(3.1.2)-1150(Named)-383(Constan)31(ts)]TJ 0 g 0 G - 0 -18.695 Td [(psb)]TJ +BT +/F27 9.9626 Tf 99.895 706.129 Td [(ith)]TJ +0 g 0 G +/F8 9.9626 Tf 18.985 0 Td [(the)-333(new)-334(threshold)-333(for)-333(comm)27(u)1(nication)-334(descriptors.)]TJ 5.922 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(global)]TJ/F8 9.9626 Tf 29.756 0 Td [(.)]TJ -62.135 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf 41.898 0 Td [(.)]TJ -71.509 -11.956 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(an)-333(in)28(teger)-333(v)55(alue)-333(greater)-333(than)-334(zero.)]TJ -24.907 -22.293 Td [(Note:)-756(the)-490(threshold)-489(v)56(alue)-489(is)-490(only)-489(queried)-489(b)28(y)-490(th)1(e)-490(library)-489(at)-489(the)-489(time)-490(a)-489(call)]TJ 0 -11.955 Td [(to)]TJ/F30 9.9626 Tf 13.432 0 Td [(psb_cdall)]TJ/F8 9.9626 Tf 51.648 0 Td [(is)-459(executed,)-491(therefore)-459(c)27(hangi)1(ng)-460(the)-459(threshold)-459(has)-459(no)-460(e\013ect)-459(on)]TJ -65.08 -11.955 Td [(comm)28(unication)-464(desc)-1(r)1(iptors)-465(that)-464(ha)28(v)28(e)-464(already)-464(b)-28(een)-464(initialized.)-837(Moreo)28(v)27(er)-464(the)]TJ 0 -11.956 Td [(threshold)-333(m)27(ust)-333(ha)28(v)28(e)-334(the)-333(same)-333(v)55(alue)-333(on)-333(all)-334(pro)-27(c)-1(esses.)]TJ/F27 9.9626 Tf 0 -26.393 Td [(3.1.2)-1150(Named)-383(Constan)31(ts)]TJ +0 g 0 G + 0 -18.564 Td [(psb)]TJ ET q -1 0 0 1 117.832 687.633 cm +1 0 0 1 117.832 555.391 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 687.434 Td [(none)]TJ +/F27 9.9626 Tf 121.269 555.192 Td [(none)]TJ ET q -1 0 0 1 145.666 687.633 cm +1 0 0 1 145.666 555.391 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 154.084 687.434 Td [(Generic)-333(no-op;)]TJ +/F8 9.9626 Tf 154.084 555.192 Td [(Generic)-333(no-op;)]TJ 0 g 0 G -/F27 9.9626 Tf -54.189 -20.583 Td [(psb)]TJ +/F27 9.9626 Tf -54.189 -20.301 Td [(psb)]TJ ET q -1 0 0 1 117.832 667.051 cm +1 0 0 1 117.832 535.09 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 666.851 Td [(ro)-32(ot)]TJ +/F27 9.9626 Tf 121.269 534.891 Td [(ro)-32(ot)]TJ ET q -1 0 0 1 142.905 667.051 cm +1 0 0 1 142.905 535.09 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 151.324 666.851 Td [(Default)-333(ro)-28(ot)-333(pro)-28(cess)-334(for)-333(broadcast)-333(and)-333(scatte)-1(r)-333(op)-28(erations;)]TJ +/F8 9.9626 Tf 151.324 534.891 Td [(Default)-333(ro)-28(ot)-333(pro)-28(cess)-334(for)-333(broadcast)-333(and)-333(scatte)-1(r)-333(op)-28(erations;)]TJ 0 g 0 G -/F27 9.9626 Tf -51.429 -20.582 Td [(psb)]TJ +/F27 9.9626 Tf -51.429 -20.301 Td [(psb)]TJ ET q -1 0 0 1 117.832 646.468 cm +1 0 0 1 117.832 514.789 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 646.269 Td [(nohalo)]TJ +/F27 9.9626 Tf 121.269 514.59 Td [(nohalo)]TJ ET q -1 0 0 1 154.895 646.468 cm +1 0 0 1 154.895 514.789 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 163.314 646.269 Td [(Do)-333(not)-334(fetc)28(h)-333(halo)-333(elem)-1(en)28(ts;)]TJ +/F8 9.9626 Tf 163.314 514.59 Td [(Do)-333(not)-334(fetc)28(h)-333(halo)-333(elem)-1(en)28(ts;)]TJ 0 g 0 G -/F27 9.9626 Tf -63.419 -20.583 Td [(psb)]TJ +/F27 9.9626 Tf -63.419 -20.301 Td [(psb)]TJ ET q -1 0 0 1 117.832 625.886 cm +1 0 0 1 117.832 494.489 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 625.686 Td [(halo)]TJ +/F27 9.9626 Tf 121.269 494.289 Td [(halo)]TJ ET q -1 0 0 1 142.802 625.886 cm +1 0 0 1 142.802 494.489 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 151.22 625.686 Td [(F)83(etc)28(h)-333(halo)-334(elemen)28(ts)-333(from)-334(neigh)28(b)-27(ouring)-334(pro)-27(ces)-1(ses;)]TJ +/F8 9.9626 Tf 151.22 494.289 Td [(F)83(etc)28(h)-333(halo)-334(elemen)28(ts)-333(from)-334(neigh)28(b)-27(ouring)-334(pro)-27(ces)-1(ses;)]TJ 0 g 0 G -/F27 9.9626 Tf -51.325 -20.582 Td [(psb)]TJ +/F27 9.9626 Tf -51.325 -20.3 Td [(psb)]TJ ET q -1 0 0 1 117.832 605.303 cm +1 0 0 1 117.832 474.188 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 605.104 Td [(sum)]TJ +/F27 9.9626 Tf 121.269 473.989 Td [(sum)]TJ ET q -1 0 0 1 142.388 605.303 cm +1 0 0 1 142.388 474.188 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 150.806 605.104 Td [(Sum)-333(o)27(v)28(erlapp)-27(e)-1(d)-333(elemen)28(ts)]TJ +/F8 9.9626 Tf 150.806 473.989 Td [(Sum)-333(o)27(v)28(erlapp)-27(e)-1(d)-333(elemen)28(ts)]TJ 0 g 0 G -/F27 9.9626 Tf -50.911 -20.583 Td [(psb)]TJ +/F27 9.9626 Tf -50.911 -20.301 Td [(psb)]TJ ET q -1 0 0 1 117.832 584.721 cm +1 0 0 1 117.832 453.887 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 584.521 Td [(a)32(vg)]TJ +/F27 9.9626 Tf 121.269 453.688 Td [(a)32(vg)]TJ ET q -1 0 0 1 138.983 584.721 cm +1 0 0 1 138.983 453.887 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 147.401 584.521 Td [(Av)28(erage)-334(o)28(v)28(erlapp)-28(ed)-333(elemen)28(ts)]TJ +/F8 9.9626 Tf 147.401 453.688 Td [(Av)28(erage)-334(o)28(v)28(erlapp)-28(ed)-333(elemen)28(ts)]TJ 0 g 0 G -/F27 9.9626 Tf -47.506 -20.582 Td [(psb)]TJ +/F27 9.9626 Tf -47.506 -20.301 Td [(psb)]TJ ET q -1 0 0 1 117.832 564.138 cm +1 0 0 1 117.832 433.586 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 563.939 Td [(comm)]TJ +/F27 9.9626 Tf 121.269 433.387 Td [(comm)]TJ ET q -1 0 0 1 151.872 564.138 cm +1 0 0 1 151.872 433.586 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 155.309 563.939 Td [(halo)]TJ +/F27 9.9626 Tf 155.309 433.387 Td [(halo)]TJ ET q -1 0 0 1 176.842 564.138 cm +1 0 0 1 176.842 433.586 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 185.26 563.939 Td [(Exc)28(hange)-334(d)1(ata)-334(based)-333(on)-333(the)]TJ/F30 9.9626 Tf 126.387 0 Td [(halo_index)]TJ/F8 9.9626 Tf 55.625 0 Td [(list;)]TJ +/F8 9.9626 Tf 185.26 433.387 Td [(Exc)28(hange)-334(d)1(ata)-334(based)-333(on)-333(the)]TJ/F30 9.9626 Tf 126.387 0 Td [(halo_index)]TJ/F8 9.9626 Tf 55.625 0 Td [(list;)]TJ 0 g 0 G -/F27 9.9626 Tf -267.377 -20.583 Td [(psb)]TJ +/F27 9.9626 Tf -267.377 -20.301 Td [(psb)]TJ ET q -1 0 0 1 117.832 543.556 cm +1 0 0 1 117.832 413.286 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 543.356 Td [(comm)]TJ +/F27 9.9626 Tf 121.269 413.086 Td [(comm)]TJ ET q -1 0 0 1 151.872 543.556 cm +1 0 0 1 151.872 413.286 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 155.309 543.356 Td [(ext)]TJ +/F27 9.9626 Tf 155.309 413.086 Td [(ext)]TJ ET q -1 0 0 1 171.75 543.556 cm +1 0 0 1 171.75 413.286 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 180.168 543.356 Td [(Exc)28(hange)-334(d)1(ata)-334(based)-333(on)-333(the)]TJ/F30 9.9626 Tf 126.387 0 Td [(ext_index)]TJ/F8 9.9626 Tf 50.394 0 Td [(list;)]TJ +/F8 9.9626 Tf 180.168 413.086 Td [(Exc)28(hange)-334(d)1(ata)-334(based)-333(on)-333(the)]TJ/F30 9.9626 Tf 126.387 0 Td [(ext_index)]TJ/F8 9.9626 Tf 50.394 0 Td [(list;)]TJ 0 g 0 G -/F27 9.9626 Tf -257.054 -20.582 Td [(psb)]TJ +/F27 9.9626 Tf -257.054 -20.3 Td [(psb)]TJ ET q -1 0 0 1 117.832 522.973 cm +1 0 0 1 117.832 392.985 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 522.774 Td [(comm)]TJ +/F27 9.9626 Tf 121.269 392.786 Td [(comm)]TJ ET q -1 0 0 1 151.872 522.973 cm +1 0 0 1 151.872 392.985 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 155.309 522.774 Td [(o)32(vr)]TJ +/F27 9.9626 Tf 155.309 392.786 Td [(o)32(vr)]TJ ET q -1 0 0 1 172.172 522.973 cm +1 0 0 1 172.172 392.985 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 180.59 522.774 Td [(Exc)28(hange)-334(d)1(ata)-334(based)-333(on)-333(the)]TJ/F30 9.9626 Tf 126.387 0 Td [(ovrlap_index)]TJ/F8 9.9626 Tf 66.085 0 Td [(list;)]TJ +/F8 9.9626 Tf 180.59 392.786 Td [(Exc)28(hange)-334(d)1(ata)-334(based)-333(on)-333(the)]TJ/F30 9.9626 Tf 126.387 0 Td [(ovrlap_index)]TJ/F8 9.9626 Tf 66.085 0 Td [(list;)]TJ 0 g 0 G -/F27 9.9626 Tf -273.167 -20.583 Td [(psb)]TJ +/F27 9.9626 Tf -273.167 -20.301 Td [(psb)]TJ ET q -1 0 0 1 117.832 502.391 cm +1 0 0 1 117.832 372.684 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 121.269 502.191 Td [(comm)]TJ +/F27 9.9626 Tf 121.269 372.485 Td [(comm)]TJ ET q -1 0 0 1 151.872 502.391 cm +1 0 0 1 151.872 372.684 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 155.309 502.191 Td [(mo)32(v)]TJ +/F27 9.9626 Tf 155.309 372.485 Td [(mo)32(v)]TJ ET q -1 0 0 1 177.001 502.391 cm +1 0 0 1 177.001 372.684 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q 0 g 0 G BT -/F8 9.9626 Tf 185.419 502.191 Td [(Exc)28(hange)-334(d)1(ata)-334(based)-333(on)-333(the)]TJ/F30 9.9626 Tf 126.388 0 Td [(ovr_mst_idx)]TJ/F8 9.9626 Tf 60.854 0 Td [(list;)]TJ/F16 11.9552 Tf -272.766 -28.76 Td [(3.2)-1125(Sparse)-375(Matrix)-375(class)]TJ/F8 9.9626 Tf 0 -18.695 Td [(The)]TJ/F30 9.9626 Tf 20.653 0 Td [(psb)]TJ +/F8 9.9626 Tf 185.419 372.485 Td [(Exc)28(hange)-334(d)1(ata)-334(based)-333(on)-333(the)]TJ/F30 9.9626 Tf 126.388 0 Td [(ovr_mst_idx)]TJ/F8 9.9626 Tf 60.854 0 Td [(list;)]TJ/F16 11.9552 Tf -272.766 -28.386 Td [(3.2)-1125(Sparse)-375(Matrix)-375(class)]TJ/F8 9.9626 Tf 0 -18.564 Td [(The)]TJ/F30 9.9626 Tf 20.653 0 Td [(psb)]TJ ET q -1 0 0 1 136.867 454.935 cm +1 0 0 1 136.867 325.734 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 140.005 454.736 Td [(Tspmat)]TJ +/F30 9.9626 Tf 140.005 325.535 Td [(Tspmat)]TJ ET q -1 0 0 1 172.015 454.935 cm +1 0 0 1 172.015 325.734 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 175.153 454.736 Td [(type)]TJ/F8 9.9626 Tf 24.416 0 Td [(class)-351(con)28(tains)-351(all)-351(information)-350(ab)-28(out)-351(the)-351(lo)-27(cal)-351(p)-28(ortion)-351(of)]TJ -99.674 -11.955 Td [(the)-249(sparse)-249(matrix)-248(and)-249(its)-249(storage)-249(mo)-27(de.)-417(Its)-248(design)-249(is)-249(based)-249(on)-248(the)-249(ST)83(A)83(TE)-248(design)]TJ 0 -11.955 Td [(pattern)-347([)]TJ +/F30 9.9626 Tf 175.153 325.535 Td [(type)]TJ/F8 9.9626 Tf 24.416 0 Td [(class)-351(con)28(tains)-351(all)-351(information)-350(ab)-28(out)-351(the)-351(lo)-27(cal)-351(p)-28(ortion)-351(of)]TJ -99.674 -11.956 Td [(the)-249(sparse)-249(matrix)-248(and)-249(its)-249(storage)-249(mo)-27(de.)-417(Its)-248(design)-249(is)-249(based)-249(on)-248(the)-249(ST)83(A)83(TE)-248(design)]TJ 0 -11.955 Td [(pattern)-347([)]TJ 1 0 0 rg 1 0 0 RG [(13)]TJ 0 g 0 G @@ -5832,126 +5837,51 @@ BT 0 g 0 G [-347(where)]TJ/F30 9.9626 Tf 0 -11.955 Td [(T)]TJ/F8 9.9626 Tf 8.552 0 Td [(is)-333(a)-334(placeholder)-333(for)-333(the)-334(d)1(ata)-334(t)28(yp)-28(e)-333(and)-333(precision)-334(v)56(arian)28(ts)]TJ 0 g 0 G -/F27 9.9626 Tf -8.552 -20.419 Td [(S)]TJ +/F27 9.9626 Tf -8.552 -20.207 Td [(S)]TJ 0 g 0 G /F8 9.9626 Tf 11.347 0 Td [(Single)-333(precision)-334(real;)]TJ 0 g 0 G -/F27 9.9626 Tf -11.347 -20.582 Td [(D)]TJ +/F27 9.9626 Tf -11.347 -20.301 Td [(D)]TJ 0 g 0 G /F8 9.9626 Tf 13.768 0 Td [(Double)-333(precision)-334(real;)]TJ 0 g 0 G -/F27 9.9626 Tf -13.768 -20.583 Td [(C)]TJ +/F27 9.9626 Tf -13.768 -20.3 Td [(C)]TJ 0 g 0 G /F8 9.9626 Tf 13.256 0 Td [(Single)-333(precision)-334(complex;)]TJ 0 g 0 G -/F27 9.9626 Tf -13.256 -20.582 Td [(Z)]TJ +/F27 9.9626 Tf -13.256 -20.301 Td [(Z)]TJ 0 g 0 G -/F8 9.9626 Tf 11.983 0 Td [(Double)-333(precision)-334(complex.)]TJ -11.983 -20.418 Td [(The)-222(actual)-222(data)-223(is)-222(con)28(tained)-222(in)-222(the)-223(p)-27(olymorphic)-223(comp)-27(onen)27(t)]TJ/F30 9.9626 Tf 255.515 0 Td [(a%a)]TJ/F8 9.9626 Tf 17.905 0 Td [(of)-222(t)28(yp)-28(e)]TJ/F30 9.9626 Tf 31.548 0 Td [(psb)]TJ +/F8 9.9626 Tf 11.983 0 Td [(Double)-333(precision)-334(complex.)]TJ -11.983 -20.207 Td [(The)-222(actual)-222(data)-223(is)-222(con)28(tained)-222(in)-222(the)-223(p)-27(olymorphic)-223(comp)-27(onen)27(t)]TJ/F30 9.9626 Tf 255.515 0 Td [(a%a)]TJ/F8 9.9626 Tf 17.905 0 Td [(of)-222(t)28(yp)-28(e)]TJ/F30 9.9626 Tf 31.548 0 Td [(psb)]TJ ET q -1 0 0 1 421.182 316.486 cm +1 0 0 1 421.182 188.552 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 424.32 316.287 Td [(T)]TJ +/F30 9.9626 Tf 424.32 188.353 Td [(T)]TJ ET q -1 0 0 1 430.178 316.486 cm +1 0 0 1 430.178 188.552 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 433.316 316.287 Td [(base)]TJ +/F30 9.9626 Tf 433.316 188.353 Td [(base)]TJ ET q -1 0 0 1 454.865 316.486 cm +1 0 0 1 454.865 188.552 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 458.003 316.287 Td [(sparse)]TJ +/F30 9.9626 Tf 458.003 188.353 Td [(sparse)]TJ ET q -1 0 0 1 490.013 316.486 cm +1 0 0 1 490.013 188.552 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 493.151 316.287 Td [(mat)]TJ/F8 9.9626 Tf 15.691 0 Td [(;)]TJ -408.947 -11.955 Td [(its)-300(sp)-28(eci\014c)-301(la)28(y)28(out)-300(can)-301(b)-28(e)-300(c)28(hosen)-301(dyn)1(am)-1(ically)-300(among)-300(the)-301(prede\014ned)-300(t)28(yp)-28(es,)-307(or)-300(an)]TJ 0 -11.956 Td [(en)28(tirely)-419(new)-419(storage)-419(la)28(y)27(out)-419(can)-419(b)-27(e)-419(implemen)27(ted)-419(and)-418(pass)-1(ed)-418(to)-419(the)-419(library)-419(at)]TJ 0 -11.955 Td [(run)28(time)-420(via)-419(the)]TJ/F30 9.9626 Tf 73.447 0 Td [(psb_spasb)]TJ/F8 9.9626 Tf 51.252 0 Td [(routine.)-703(The)-419(follo)28(wing)-420(v)28(ery)-419(common)-420(formats)-419(are)]TJ +/F30 9.9626 Tf 493.151 188.353 Td [(mat)]TJ/F8 9.9626 Tf 15.691 0 Td [(;)]TJ -408.947 -11.955 Td [(its)-300(sp)-28(eci\014c)-301(la)28(y)28(out)-300(can)-301(b)-28(e)-300(c)28(hosen)-301(dyn)1(am)-1(ically)-300(among)-300(the)-301(prede\014ned)-300(t)28(yp)-28(es,)-307(or)-300(an)]TJ 0 -11.955 Td [(en)28(tirely)-419(new)-419(storage)-419(la)28(y)27(out)-419(can)-419(b)-27(e)-419(implemen)27(ted)-419(and)-418(pass)-1(ed)-418(to)-419(the)-419(library)-419(at)]TJ 0 -11.955 Td [(run)28(time)-420(via)-419(the)]TJ/F30 9.9626 Tf 73.447 0 Td [(psb_spasb)]TJ/F8 9.9626 Tf 51.252 0 Td [(routine.)-703(The)-419(follo)28(wing)-420(v)28(ery)-419(common)-420(formats)-419(are)]TJ -124.699 -11.956 Td [(precompiled)-333(in)-334(PSBLAS)-333(and)-333(th)28(us)-334(are)-333(alw)28(a)28(ys)-334(a)28(v)56(ailable:)]TJ 0 g 0 G -0 g 0 G -0 g 0 G -0 g 0 G -0 g 0 G -/F30 9.9626 Tf -88.461 -20.586 Td [(type)-525(::)-525(psb_Tspmat_type)]TJ 10.461 -11.955 Td [(class\050psb_T_base_sparse_mat\051,)-525(allocatable)-1050(::)-525(a)]TJ -10.461 -11.955 Td [(end)-525(type)-1050(psb_Tspmat_type)]TJ -0 g 0 G -/F8 9.9626 Tf -24.739 -30.054 Td [(Figure)-333(4:)-889(The)-333(PSBLAS)-334(de\014ned)-333(data)-333(t)28(yp)-28(e)-334(that)-333(con)28(tains)-333(a)-334(sparse)-333(matrix.)]TJ -0 g 0 G -0 g 0 G - -11.499 -23.962 Td [(precompiled)-333(in)-334(PSBLAS)-333(and)-333(th)28(us)-334(are)-333(alw)28(a)28(ys)-334(a)28(v)56(ailable:)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -20.418 Td [(psb)]TJ -ET -q -1 0 0 1 117.832 161.69 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.269 161.491 Td [(T)]TJ -ET -q -1 0 0 1 129.926 161.69 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 133.364 161.491 Td [(co)-32(o)]TJ -ET -q -1 0 0 1 150.918 161.69 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 154.355 161.491 Td [(sparse)]TJ -ET -q -1 0 0 1 185.985 161.69 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 189.422 161.491 Td [(mat)]TJ -0 g 0 G -/F8 9.9626 Tf 24.554 0 Td [(Co)-28(ordinate)-333(storage;)]TJ -0 g 0 G -/F27 9.9626 Tf -114.081 -20.583 Td [(psb)]TJ -ET -q -1 0 0 1 117.832 141.107 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.269 140.908 Td [(T)]TJ -ET -q -1 0 0 1 129.926 141.107 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 133.364 140.908 Td [(csr)]TJ -ET -q -1 0 0 1 148.38 141.107 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 151.818 140.908 Td [(sparse)]TJ -ET -q -1 0 0 1 183.447 141.107 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 186.884 140.908 Td [(mat)]TJ -0 g 0 G -/F8 9.9626 Tf 24.554 0 Td [(Compressed)-333(storage)-334(b)28(y)-333(ro)27(ws;)]TJ -0 g 0 G -/F27 9.9626 Tf -111.543 -20.582 Td [(psb)]TJ +/F27 9.9626 Tf 0 -20.206 Td [(psb)]TJ ET q 1 0 0 1 117.832 120.525 cm @@ -5965,25 +5895,25 @@ q []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 133.364 120.326 Td [(csc)]TJ +/F27 9.9626 Tf 133.364 120.326 Td [(co)-32(o)]TJ ET q -1 0 0 1 148.754 120.525 cm +1 0 0 1 150.918 120.525 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 152.191 120.326 Td [(sparse)]TJ +/F27 9.9626 Tf 154.355 120.326 Td [(sparse)]TJ ET q -1 0 0 1 183.821 120.525 cm +1 0 0 1 185.985 120.525 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 187.258 120.326 Td [(mat)]TJ +/F27 9.9626 Tf 189.422 120.326 Td [(mat)]TJ 0 g 0 G -/F8 9.9626 Tf 24.553 0 Td [(Compressed)-334(storage)-333(b)28(y)-333(columns;)]TJ +/F8 9.9626 Tf 24.554 0 Td [(Co)-28(ordinate)-333(storage;)]TJ 0 g 0 G - 54.959 -29.888 Td [(15)]TJ + 52.794 -29.888 Td [(15)]TJ 0 g 0 G ET @@ -5991,83 +5921,145 @@ endstream endobj 906 0 obj << -/Length 4142 +/Length 5360 >> stream 0 g 0 G 0 g 0 G +0 g 0 G +0 g 0 G +0 g 0 G +0 g 0 G +0 g 0 G BT -/F8 9.9626 Tf 150.705 706.129 Td [(The)-373(inner)-373(sparse)-373(matrix)-373(has)-373(an)-373(asso)-28(ciated)-373(state,)-383(whic)28(h)-373(can)-373(tak)28(e)-373(the)-373(follo)27(win)1(g)]TJ 0 -11.955 Td [(v)56(alues:)]TJ +/F30 9.9626 Tf 186.943 710.003 Td [(type)-525(::)-525(psb_Tspmat_type)]TJ 10.46 -11.955 Td [(class\050psb_T_base_sparse_mat\051,)-525(allocatable)-1050(::)-525(a)]TJ -10.46 -11.955 Td [(end)-525(type)-1050(psb_Tspmat_type)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -22.664 Td [(Build:)]TJ +/F8 9.9626 Tf -24.74 -30.054 Td [(Figure)-333(4:)-889(The)-334(P)1(SBLAS)-334(de\014ned)-333(data)-333(t)27(yp)-27(e)-334(that)-333(con)28(tains)-333(a)-334(sparse)-333(matrix.)]TJ 0 g 0 G -/F8 9.9626 Tf 35.409 0 Td [(State)-306(en)28(tered)-306(after)-307(th)1(e)-307(\014rst)-306(allo)-28(cation)1(,)-312(and)-306(b)-28(efore)-306(the)-306(\014rst)-306(assem)27(bly;)-315(in)]TJ -10.503 -11.955 Td [(this)-333(state)-334(it)-333(is)-333(p)-28(ossible)-334(to)-333(add)-333(nonzero)-333(e)-1(n)28(tries.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -23.576 Td [(Assem)32(bled:)]TJ +0 g 0 G +/F27 9.9626 Tf -11.498 -32.583 Td [(psb)]TJ +ET +q +1 0 0 1 168.641 623.655 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 172.078 623.456 Td [(T)]TJ +ET +q +1 0 0 1 180.736 623.655 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 184.173 623.456 Td [(csr)]TJ +ET +q +1 0 0 1 199.19 623.655 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 202.627 623.456 Td [(sparse)]TJ +ET +q +1 0 0 1 234.257 623.655 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 237.694 623.456 Td [(mat)]TJ +0 g 0 G +/F8 9.9626 Tf 24.553 0 Td [(Compressed)-333(s)-1(torage)-333(b)28(y)-333(ro)27(ws;)]TJ +0 g 0 G +/F27 9.9626 Tf -111.542 -21.441 Td [(psb)]TJ +ET +q +1 0 0 1 168.641 602.214 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 172.078 602.015 Td [(T)]TJ +ET +q +1 0 0 1 180.736 602.214 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 184.173 602.015 Td [(csc)]TJ +ET +q +1 0 0 1 199.563 602.214 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 203.001 602.015 Td [(sparse)]TJ +ET +q +1 0 0 1 234.63 602.214 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 238.067 602.015 Td [(mat)]TJ +0 g 0 G +/F8 9.9626 Tf 24.554 0 Td [(Compressed)-333(storage)-334(b)28(y)-333(columns;)]TJ -111.916 -21.062 Td [(The)-373(inner)-373(sparse)-373(matrix)-373(has)-373(an)-373(asso)-28(ciated)-373(state,)-383(whic)28(h)-373(can)-373(tak)28(e)-373(the)-373(follo)27(win)1(g)]TJ 0 -11.955 Td [(v)56(alues:)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -21.062 Td [(Build:)]TJ +0 g 0 G +/F8 9.9626 Tf 35.409 0 Td [(State)-306(en)28(tered)-306(after)-307(th)1(e)-307(\014rst)-306(allo)-28(cation)1(,)-312(and)-306(b)-28(efore)-306(the)-306(\014rst)-306(assem)27(bly;)-315(in)]TJ -10.503 -11.956 Td [(this)-333(state)-334(it)-333(is)-333(p)-28(ossible)-334(to)-333(add)-333(nonzero)-333(e)-1(n)28(tries.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.906 -21.441 Td [(Assem)32(bled:)]TJ 0 g 0 G /F8 9.9626 Tf 61.508 0 Td [(State)-373(en)27(tered)-373(after)-373(the)-373(a)-1(ssem)28(bly;)-393(computations)-373(using)-374(the)-373(sparse)]TJ -36.602 -11.955 Td [(matrix,)-333(suc)27(h)-333(as)-333(matrix-v)28(e)-1(ctor)-333(pro)-28(du)1(c)-1(ts,)-333(are)-333(only)-334(p)-27(ossible)-334(in)-333(this)-333(state;)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -23.576 Td [(Up)-32(date:)]TJ +/F27 9.9626 Tf -24.906 -21.441 Td [(Up)-32(date:)]TJ 0 g 0 G -/F8 9.9626 Tf 45.302 0 Td [(State)-233(en)27(tered)-233(after)-233(a)-234(r)1(e)-1(in)1(italization;)-267(this)-233(is)-234(used)-233(to)-233(handle)-234(appli)1(c)-1(ation)1(s)]TJ -20.396 -11.955 Td [(in)-395(whic)28(h)-396(the)-395(same)-395(sparsit)28(y)-395(pattern)-396(is)-395(used)-395(m)28(ultiple)-395(times)-396(with)-395(di\013eren)28(t)]TJ 0 -11.955 Td [(co)-28(e\016cien)28(ts.)-427(In)-280(this)-280(state)-280(it)-281(i)1(s)-281(only)-280(p)-27(os)-1(sibl)1(e)-281(to)-280(en)28(ter)-280(co)-28(e\016cien)28(ts)-281(f)1(or)-281(already)]TJ 0 -11.955 Td [(existing)-333(nonzero)-334(en)28(tries.)]TJ -24.906 -22.663 Td [(The)-358(only)-357(storage)-358(v)56(arian)28(t)-358(supp)-28(orting)-357(the)-358(build)-357(state)-358(is)-358(COO;)-357(all)-358(other)-358(v)56(arian)28(ts)]TJ 0 -11.956 Td [(are)-333(obtained)-334(b)28(y)-333(con)28(v)27(ersion)-333(to/from)-333(it.)]TJ/F27 9.9626 Tf 0 -30.738 Td [(3.2.1)-1150(Sparse)-383(Matrix)-384(Metho)-32(ds)]TJ 0 -20.088 Td [(get)]TJ +/F8 9.9626 Tf 45.302 0 Td [(State)-233(en)27(tered)-233(after)-233(a)-234(r)1(e)-1(in)1(italization;)-267(this)-233(is)-234(used)-233(to)-233(handle)-234(appli)1(c)-1(ation)1(s)]TJ -20.396 -11.955 Td [(in)-395(whic)28(h)-396(the)-395(same)-395(sparsit)28(y)-395(pattern)-396(is)-395(used)-395(m)28(ultiple)-395(times)-396(with)-395(di\013eren)28(t)]TJ 0 -11.955 Td [(co)-28(e\016cien)28(ts.)-427(In)-280(this)-280(state)-280(it)-281(i)1(s)-281(only)-280(p)-27(os)-1(sibl)1(e)-281(to)-280(en)28(ter)-280(co)-28(e\016cien)28(ts)-281(f)1(or)-281(already)]TJ 0 -11.955 Td [(existing)-333(nonzero)-334(en)28(tries.)]TJ -24.906 -21.062 Td [(The)-358(only)-357(storage)-358(v)56(arian)28(t)-358(supp)-28(orting)-357(the)-358(build)-357(state)-358(is)-358(COO;)-357(all)-358(other)-358(v)56(arian)28(ts)]TJ 0 -11.956 Td [(are)-333(obtained)-334(b)28(y)-333(con)28(v)27(ersion)-333(to/from)-333(it.)]TJ/F27 9.9626 Tf 0 -27.906 Td [(3.2.1)-1150(Sparse)-383(Matrix)-384(Metho)-32(ds)]TJ 0 -19.095 Td [(get)]TJ ET q -1 0 0 1 166.827 479.338 cm +1 0 0 1 166.827 365.459 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 170.264 479.139 Td [(nro)32(ws)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(ro)32(ws)-383(in)-383(a)-384(sparse)-383(matrix)]TJ +/F27 9.9626 Tf 170.264 365.259 Td [(nro)32(ws)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(ro)32(ws)-383(in)-383(a)-384(sparse)-383(matrix)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -19.559 -20.088 Td [(nr)-525(=)-525(a%get_nrows\050\051)]TJ +/F30 9.9626 Tf -19.559 -19.094 Td [(nr)-525(=)-525(a%get_nrows\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -24.656 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -23.055 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -23.576 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -21.441 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -23.576 Td [(a)]TJ + 0 -21.441 Td [(a)]TJ 0 g 0 G /F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.355 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ 0 g 0 G - -57.285 -36.611 Td [(On)-383(Return)]TJ + -57.285 -35.01 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -23.576 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -21.441 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(The)-333(n)27(um)28(b)-28(er)-333(of)-333(ro)28(ws)-334(of)-333(sparse)-333(matrix)]TJ/F30 9.9626 Tf 164.937 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ/F27 9.9626 Tf -248.554 -30.738 Td [(get)]TJ +/F8 9.9626 Tf 78.386 0 Td [(The)-333(n)27(um)28(b)-28(er)-333(of)-333(ro)28(ws)-334(of)-333(sparse)-333(matrix)]TJ/F30 9.9626 Tf 164.937 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ/F27 9.9626 Tf -248.554 -27.906 Td [(get)]TJ ET q -1 0 0 1 166.827 284.562 cm +1 0 0 1 166.827 184.115 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 170.264 284.363 Td [(ncols)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(columns)-383(in)-384(a)-383(sparse)-383(matrix)]TJ +/F27 9.9626 Tf 170.264 183.916 Td [(ncols)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(columns)-383(in)-384(a)-383(sparse)-383(matrix)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -19.559 -20.088 Td [(nc)-525(=)-525(a%get_ncols\050\051)]TJ +/F30 9.9626 Tf -19.559 -19.095 Td [(nc)-525(=)-525(a%get_ncols\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -24.656 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -23.054 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -23.576 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -21.441 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -23.575 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.355 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ -0 g 0 G - -57.285 -36.611 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -23.575 Td [(F)96(unction)-384(v)64(alue)]TJ -0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(The)-333(n)27(um)28(b)-28(er)-333(of)-333(columns)-334(of)-333(sparse)-333(matrix)]TJ/F30 9.9626 Tf 180.684 0 Td [(a)]TJ/F8 9.9626 Tf 5.23 0 Td [(.)]TJ -0 g 0 G - -97.426 -29.888 Td [(16)]TJ +/F8 9.9626 Tf 166.874 -29.888 Td [(16)]TJ 0 g 0 G ET @@ -6075,96 +6067,85 @@ endstream endobj 910 0 obj << -/Length 3830 +/Length 3499 >> stream 0 g 0 G 0 g 0 G +0 g 0 G BT -/F27 9.9626 Tf 99.895 706.129 Td [(get)]TJ +/F27 9.9626 Tf 99.895 706.129 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ +0 g 0 G + -57.286 -37.92 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -25.32 Td [(F)96(unction)-384(v)64(alue)]TJ +0 g 0 G +/F8 9.9626 Tf 78.387 0 Td [(The)-333(n)27(u)1(m)27(b)-27(e)-1(r)-333(of)-333(columns)-333(of)-334(sparse)-333(matrix)]TJ/F30 9.9626 Tf 180.683 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ/F27 9.9626 Tf -264.301 -33.052 Td [(get)]TJ ET q -1 0 0 1 116.018 706.328 cm +1 0 0 1 116.018 598.081 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 119.455 706.129 Td [(nnzeros)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(nonzero)-383(elemen)32(ts)-383(in)-384(a)-383(sparse)-383(ma)-1(trix)]TJ +/F27 9.9626 Tf 119.455 597.882 Td [(nnzeros)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(nonzero)-383(elemen)32(ts)-383(in)-384(a)-383(sparse)-383(ma)-1(trix)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -19.56 -18.549 Td [(nz)-525(=)-525(a%get_nnzeros\050\051)]TJ +/F30 9.9626 Tf -19.56 -20.9 Td [(nz)-525(=)-525(a%get_nnzeros\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -22.175 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -25.964 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -20.268 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -25.32 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -20.268 Td [(a)]TJ + 0 -25.321 Td [(a)]TJ 0 g 0 G /F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ 0 g 0 G - -57.286 -34.13 Td [(On)-383(Return)]TJ + -57.286 -37.919 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -20.268 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -25.321 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G -/F8 9.9626 Tf 78.387 0 Td [(The)-333(n)27(u)1(m)27(b)-27(e)-1(r)-333(of)-333(nonzero)-333(elem)-1(en)28(ts)-333(stored)-333(in)-334(sparse)-333(matrix)]TJ/F30 9.9626 Tf 249.979 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ/F27 9.9626 Tf -333.597 -22.261 Td [(Notes)]TJ +/F8 9.9626 Tf 78.387 0 Td [(The)-333(n)27(u)1(m)27(b)-27(e)-1(r)-333(of)-333(nonzero)-333(elem)-1(en)28(ts)-333(stored)-333(in)-334(sparse)-333(matrix)]TJ/F30 9.9626 Tf 249.979 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ/F27 9.9626 Tf -333.597 -27.313 Td [(Notes)]TJ 0 g 0 G -/F8 9.9626 Tf 12.177 -20.182 Td [(1.)]TJ +/F8 9.9626 Tf 12.177 -23.971 Td [(1.)]TJ 0 g 0 G - [-500(The)-462(function)-462(v)55(alue)-462(is)-462(sp)-28(eci\014c)-462(to)-462(the)-463(storage)-462(format)-462(of)-462(matrix)]TJ/F30 9.9626 Tf 296.649 0 Td [(a)]TJ/F8 9.9626 Tf 5.23 0 Td [(;)-527(some)]TJ -289.149 -11.955 Td [(storage)-465(formats)-466(emplo)28(y)-465(padding,)-498(th)27(u)1(s)-466(the)-465(returned)-465(v)55(alue)-465(for)-465(the)-466(same)]TJ 0 -11.955 Td [(matrix)-333(ma)27(y)-333(b)-28(e)-333(di\013eren)28(t)-334(f)1(o)-1(r)-333(di\013eren)28(t)-333(storage)-334(c)28(hoices.)]TJ/F27 9.9626 Tf -24.907 -26.351 Td [(get)]TJ + [-500(The)-462(function)-462(v)55(alue)-462(is)-462(sp)-28(eci\014c)-462(to)-462(the)-463(storage)-462(format)-462(of)-462(matrix)]TJ/F30 9.9626 Tf 296.649 0 Td [(a)]TJ/F8 9.9626 Tf 5.23 0 Td [(;)-527(some)]TJ -289.149 -11.955 Td [(storage)-465(formats)-466(emplo)28(y)-465(padding,)-498(th)27(u)1(s)-466(the)-465(returned)-465(v)55(alue)-465(for)-465(the)-466(same)]TJ 0 -11.956 Td [(matrix)-333(ma)27(y)-333(b)-28(e)-333(di\013eren)28(t)-334(f)1(o)-1(r)-333(di\013eren)28(t)-333(storage)-334(c)28(hoices.)]TJ/F27 9.9626 Tf -24.907 -33.052 Td [(get)]TJ ET q -1 0 0 1 116.018 466.012 cm +1 0 0 1 116.018 317.135 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 119.455 465.812 Td [(size)-503(|)-503(Get)-503(maxim)32(um)-503(n)32(um)32(b)-32(er)-503(of)-503(nonzero)-503(elemen)32(ts)-503(in)-503(a)-503(sparse)]TJ -19.56 -11.955 Td [(matrix)]TJ +/F27 9.9626 Tf 119.455 316.936 Td [(size)-503(|)-503(Get)-503(maxim)32(um)-503(n)32(um)32(b)-32(er)-503(of)-503(nonzero)-503(elemen)32(ts)-503(in)-503(a)-503(sparse)]TJ -19.56 -11.956 Td [(matrix)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf 0 -18.549 Td [(maxnz)-525(=)-525(a%get_size\050\051)]TJ +/F30 9.9626 Tf 0 -20.899 Td [(maxnz)-525(=)-525(a%get_size\050\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -22.175 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -25.964 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -20.268 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -25.321 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -20.268 Td [(a)]TJ + 0 -25.32 Td [(a)]TJ 0 g 0 G /F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ 0 g 0 G - -57.286 -34.13 Td [(On)-383(Return)]TJ + -57.286 -37.92 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -20.268 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -25.32 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G -/F8 9.9626 Tf 78.387 0 Td [(The)-253(maxim)28(um)-254(n)28(um)28(b)-28(er)-253(of)-253(nonzero)-254(elemen)28(ts)-253(that)-253(can)-254(b)-27(e)-254(stored)]TJ -53.48 -11.955 Td [(in)-333(sparse)-334(matrix)]TJ/F30 9.9626 Tf 74.056 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(using)-333(its)-334(curren)28(t)-333(memory)-334(allo)-27(cation.)]TJ/F27 9.9626 Tf -107.514 -26.351 Td [(sizeof)-383(|)-384(Get)-383(memory)-383(o)-32(ccupation)-384(in)-383(b)32(ytes)-384(of)-383(a)-383(sparse)-384(matrix)]TJ +/F8 9.9626 Tf 78.387 0 Td [(The)-253(maxim)28(um)-254(n)28(um)28(b)-28(er)-253(of)-253(nonzero)-254(elemen)28(ts)-253(that)-253(can)-254(b)-27(e)-254(stored)]TJ -53.48 -11.955 Td [(in)-333(sparse)-334(matrix)]TJ/F30 9.9626 Tf 74.056 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(using)-333(its)-334(curren)28(t)-333(memory)-334(allo)-27(cation.)]TJ 0 g 0 G -0 g 0 G -/F30 9.9626 Tf 0 -18.548 Td [(memory_size)-525(=)-525(a%sizeof\050\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -22.175 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -20.268 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -20.268 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ -0 g 0 G - -57.286 -34.13 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -20.268 Td [(F)96(unction)-384(v)64(alue)]TJ -0 g 0 G -/F8 9.9626 Tf 78.387 0 Td [(The)-333(memory)-334(o)-28(ccupati)1(on)-334(in)-333(b)28(ytes.)]TJ -0 g 0 G - 88.488 -29.888 Td [(17)]TJ + 59.361 -29.888 Td [(17)]TJ 0 g 0 G ET @@ -6175,19 +6156,19 @@ endobj /Type /ObjStm /N 100 /First 865 -/Length 8968 +/Length 8969 >> stream 821 0 822 56 823 112 824 168 825 224 826 280 827 336 828 392 829 448 812 505 835 635 811 777 833 929 837 1076 27 1133 838 1189 839 1246 840 1303 841 1360 842 1417 843 1474 31 1531 834 1587 846 1730 844 1864 848 2011 35 2067 39 2122 849 2177 845 2234 -856 2352 850 2502 851 2649 852 2800 858 2952 859 3009 860 3066 861 3123 862 3180 863 3237 -864 3294 865 3351 866 3407 867 3464 855 3521 869 3613 853 3755 854 3907 871 4059 872 4115 -873 4171 874 4227 875 4283 876 4339 43 4396 47 4451 868 4504 880 4596 877 4738 878 4884 -882 5030 51 5087 55 5143 59 5199 879 5255 884 5373 886 5487 63 5543 67 5598 71 5653 -883 5708 889 5800 891 5914 75 5971 892 6027 79 6084 83 6140 888 6196 897 6288 893 6438 -894 6595 895 6745 899 6891 87 6947 91 7002 900 7057 901 7114 902 7171 896 7228 905 7333 -907 7447 95 7504 99 7560 103 7616 904 7673 909 7765 911 7879 107 7935 912 7991 111 8047 +854 2352 850 2502 851 2649 852 2801 856 2953 857 3010 858 3067 859 3124 860 3181 861 3238 +853 3295 865 3387 862 3529 863 3681 867 3833 868 3889 869 3945 870 4001 871 4056 872 4112 +873 4168 874 4224 875 4280 876 4336 864 4393 880 4485 877 4627 878 4773 882 4919 43 4976 +47 5032 51 5088 55 5144 879 5200 884 5318 886 5432 59 5488 63 5543 67 5598 883 5653 +889 5745 891 5859 71 5916 75 5972 892 6028 79 6085 83 6141 888 6197 897 6289 893 6439 +894 6596 895 6746 899 6892 87 6948 91 7003 900 7058 901 7115 896 7172 905 7277 907 7391 +903 7448 95 7505 99 7561 103 7617 904 7674 909 7766 911 7880 107 7936 912 7992 111 8048 % 821 0 obj << /D [813 0 R /XYZ 99.895 539.509 null] @@ -6309,7 +6290,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [269.318 225.936 276.292 236.784] +/Rect [269.318 174.287 276.292 185.135] /A << /S /GoTo /D (section.6) >> >> % 848 0 obj @@ -6322,22 +6303,22 @@ stream >> % 39 0 obj << -/D [846 0 R /XYZ 99.895 331.305 null] +/D [846 0 R /XYZ 99.895 280.417 null] >> % 849 0 obj << -/D [846 0 R /XYZ 342.427 288.724 null] +/D [846 0 R /XYZ 342.427 237.273 null] >> % 845 0 obj << /Font << /F16 558 0 R /F8 561 0 R /F30 769 0 R /F27 560 0 R /F14 772 0 R >> /ProcSet [ /PDF /Text ] >> -% 856 0 obj +% 854 0 obj << /Type /Page -/Contents 857 0 R -/Resources 855 0 R +/Contents 855 0 R +/Resources 853 0 R /MediaBox [0 0 595.276 841.89] /Parent 831 0 R /Annots [ 850 0 R 851 0 R 852 0 R ] @@ -6347,7 +6328,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [452.103 458.757 459.077 470.712] +/Rect [452.103 399.657 459.077 411.612] /A << /S /GoTo /D (section.6) >> >> % 851 0 obj @@ -6355,7 +6336,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [356.323 258.941 371.046 269.79] +/Rect [356.323 194.074 371.046 204.923] /A << /S /GoTo /D (subsection.3.3) >> >> % 852 0 obj @@ -6363,112 +6344,104 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [356.323 215.425 371.046 226.273] +/Rect [356.323 149.756 371.046 160.604] /A << /S /GoTo /D (subsection.3.3) >> >> +% 856 0 obj +<< +/D [854 0 R /XYZ 149.705 753.953 null] +>> +% 857 0 obj +<< +/D [854 0 R /XYZ 150.705 294.274 null] +>> % 858 0 obj << -/D [856 0 R /XYZ 149.705 753.953 null] +/D [854 0 R /XYZ 150.705 278.093 null] >> % 859 0 obj << -/D [856 0 R /XYZ 150.705 355.818 null] +/D [854 0 R /XYZ 150.705 261.911 null] >> % 860 0 obj << -/D [856 0 R /XYZ 150.705 340.197 null] +/D [854 0 R /XYZ 150.705 245.729 null] >> % 861 0 obj << -/D [856 0 R /XYZ 150.705 324.575 null] ->> -% 862 0 obj -<< -/D [856 0 R /XYZ 150.705 308.954 null] ->> -% 863 0 obj -<< -/D [856 0 R /XYZ 150.705 293.332 null] ->> -% 864 0 obj -<< -/D [856 0 R /XYZ 150.705 179.041 null] ->> -% 865 0 obj -<< -/D [856 0 R /XYZ 150.705 163.42 null] ->> -% 866 0 obj -<< -/D [856 0 R /XYZ 150.705 147.798 null] ->> -% 867 0 obj -<< -/D [856 0 R /XYZ 150.705 132.177 null] ->> -% 855 0 obj -<< -/Font << /F27 560 0 R /F8 561 0 R /F14 772 0 R >> -/ProcSet [ /PDF /Text ] ->> -% 869 0 obj -<< -/Type /Page -/Contents 870 0 R -/Resources 868 0 R -/MediaBox [0 0 595.276 841.89] -/Parent 831 0 R -/Annots [ 853 0 R 854 0 R ] +/D [854 0 R /XYZ 150.705 229.547 null] >> % 853 0 obj << -/Type /Annot -/Subtype /Link -/Border[0 0 0]/H/I/C[1 0 0] -/Rect [305.513 683.645 320.236 694.494] -/A << /S /GoTo /D (subsection.3.3) >> +/Font << /F14 772 0 R /F8 561 0 R /F27 560 0 R >> +/ProcSet [ /PDF /Text ] >> -% 854 0 obj +% 865 0 obj +<< +/Type /Page +/Contents 866 0 R +/Resources 864 0 R +/MediaBox [0 0 595.276 841.89] +/Parent 831 0 R +/Annots [ 862 0 R 863 0 R ] +>> +% 862 0 obj << /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [305.513 640.185 320.236 651.033] +/Rect [305.513 611.433 320.236 622.281] /A << /S /GoTo /D (subsection.3.3) >> >> +% 863 0 obj +<< +/Type /Annot +/Subtype /Link +/Border[0 0 0]/H/I/C[1 0 0] +/Rect [305.513 564.905 320.236 575.753] +/A << /S /GoTo /D (subsection.3.3) >> +>> +% 867 0 obj +<< +/D [865 0 R /XYZ 98.895 753.953 null] +>> +% 868 0 obj +<< +/D [865 0 R /XYZ 99.895 716.092 null] +>> +% 869 0 obj +<< +/D [865 0 R /XYZ 99.895 701.526 null] +>> +% 870 0 obj +<< +/D [865 0 R /XYZ 99.895 684.24 null] +>> % 871 0 obj << -/D [869 0 R /XYZ 98.895 753.953 null] +/D [865 0 R /XYZ 99.895 666.954 null] >> % 872 0 obj << -/D [869 0 R /XYZ 99.895 716.092 null] +/D [865 0 R /XYZ 99.895 649.667 null] >> % 873 0 obj << -/D [869 0 R /XYZ 99.895 615.842 null] +/D [865 0 R /XYZ 99.895 535.287 null] >> % 874 0 obj << -/D [869 0 R /XYZ 99.895 600.277 null] +/D [865 0 R /XYZ 99.895 518.001 null] >> % 875 0 obj << -/D [869 0 R /XYZ 99.895 584.712 null] +/D [865 0 R /XYZ 99.895 500.715 null] >> % 876 0 obj << -/D [869 0 R /XYZ 147.412 369.037 null] +/D [865 0 R /XYZ 147.412 273.553 null] >> -% 43 0 obj -<< -/D [869 0 R /XYZ 99.895 209.589 null] ->> -% 47 0 obj -<< -/D [869 0 R /XYZ 99.895 191.2 null] ->> -% 868 0 obj +% 864 0 obj << /Font << /F8 561 0 R /F27 560 0 R /F30 769 0 R >> /ProcSet [ /PDF /Text ] @@ -6487,7 +6460,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [351.231 623.115 358.204 635.07] +/Rect [351.231 524.53 358.204 536.485] /A << /S /GoTo /D (section.1) >> >> % 878 0 obj @@ -6495,28 +6468,32 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [186.34 408.904 193.314 420.859] +/Rect [186.34 314.707 193.314 326.662] /A << /S /GoTo /D (section.1) >> >> % 882 0 obj << /D [880 0 R /XYZ 149.705 753.953 null] >> +% 43 0 obj +<< +/D [880 0 R /XYZ 150.705 716.092 null] +>> +% 47 0 obj +<< +/D [880 0 R /XYZ 150.705 699.536 null] +>> % 51 0 obj << -/D [880 0 R /XYZ 150.705 599.327 null] +/D [880 0 R /XYZ 150.705 501.668 null] >> % 55 0 obj << -/D [880 0 R /XYZ 150.705 385.116 null] ->> -% 59 0 obj -<< -/D [880 0 R /XYZ 150.705 194.815 null] +/D [880 0 R /XYZ 150.705 291.844 null] >> % 879 0 obj << -/Font << /F27 560 0 R /F8 561 0 R /F14 772 0 R /F10 771 0 R /F30 769 0 R >> +/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R /F14 772 0 R /F10 771 0 R >> /ProcSet [ /PDF /Text ] >> % 884 0 obj @@ -6531,21 +6508,21 @@ stream << /D [884 0 R /XYZ 98.895 753.953 null] >> +% 59 0 obj +<< +/D [884 0 R /XYZ 99.895 718.084 null] +>> % 63 0 obj << -/D [884 0 R /XYZ 99.895 614.689 null] +/D [884 0 R /XYZ 99.895 532.754 null] >> % 67 0 obj << -/D [884 0 R /XYZ 99.895 363.684 null] ->> -% 71 0 obj -<< -/D [884 0 R /XYZ 99.895 192.327 null] +/D [884 0 R /XYZ 99.895 279.429 null] >> % 883 0 obj << -/Font << /F27 560 0 R /F8 561 0 R /F30 769 0 R >> +/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R >> /ProcSet [ /PDF /Text ] >> % 889 0 obj @@ -6560,25 +6537,29 @@ stream << /D [889 0 R /XYZ 149.705 753.953 null] >> +% 71 0 obj +<< +/D [889 0 R /XYZ 150.705 718.084 null] +>> % 75 0 obj << -/D [889 0 R /XYZ 150.705 611.434 null] +/D [889 0 R /XYZ 150.705 519.229 null] >> % 892 0 obj << -/D [889 0 R /XYZ 395.482 457.068 null] +/D [889 0 R /XYZ 395.482 355.253 null] >> % 79 0 obj << -/D [889 0 R /XYZ 150.705 412.181 null] +/D [889 0 R /XYZ 150.705 305.167 null] >> % 83 0 obj << -/D [889 0 R /XYZ 150.705 311.051 null] +/D [889 0 R /XYZ 150.705 194.677 null] >> % 888 0 obj << -/Font << /F27 560 0 R /F8 561 0 R /F30 769 0 R >> +/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R >> /ProcSet [ /PDF /Text ] >> % 897 0 obj @@ -6595,7 +6576,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[0 1 0] -/Rect [137.251 429.829 149.206 438.242] +/Rect [137.251 300.628 149.206 309.041] /A << /S /GoTo /D (cite.DesignPatterns) >> >> % 894 0 obj @@ -6603,7 +6584,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[0 1 0] -/Rect [218.095 429.829 230.05 438.242] +/Rect [218.095 300.628 230.05 309.041] /A << /S /GoTo /D (cite.Sparse03) >> >> % 895 0 obj @@ -6611,7 +6592,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [408.687 427.339 415.661 439.294] +/Rect [408.687 298.137 415.661 310.092] /A << /S /GoTo /D (figure.4) >> >> % 899 0 obj @@ -6620,23 +6601,19 @@ stream >> % 87 0 obj << -/D [897 0 R /XYZ 99.895 716.092 null] +/D [897 0 R /XYZ 99.895 583.867 null] >> % 91 0 obj << -/D [897 0 R /XYZ 99.895 485.606 null] +/D [897 0 R /XYZ 99.895 356.203 null] >> % 900 0 obj << -/D [897 0 R /XYZ 120.548 454.736 null] +/D [897 0 R /XYZ 120.548 325.535 null] >> % 901 0 obj << -/D [897 0 R /XYZ 404.863 316.287 null] ->> -% 902 0 obj -<< -/D [897 0 R /XYZ 155.008 217.826 null] +/D [897 0 R /XYZ 404.863 188.353 null] >> % 896 0 obj << @@ -6655,21 +6632,25 @@ stream << /D [905 0 R /XYZ 149.705 753.953 null] >> +% 903 0 obj +<< +/D [905 0 R /XYZ 205.817 667.994 null] +>> % 95 0 obj << -/D [905 0 R /XYZ 150.705 509.604 null] +/D [905 0 R /XYZ 150.705 394.197 null] >> % 99 0 obj << -/D [905 0 R /XYZ 150.705 491.094 null] +/D [905 0 R /XYZ 150.705 377.215 null] >> % 103 0 obj << -/D [905 0 R /XYZ 150.705 296.318 null] +/D [905 0 R /XYZ 150.705 195.871 null] >> % 904 0 obj << -/Font << /F8 561 0 R /F27 560 0 R /F30 769 0 R >> +/Font << /F30 769 0 R /F8 561 0 R /F27 560 0 R >> /ProcSet [ /PDF /Text ] >> % 909 0 obj @@ -6686,22 +6667,917 @@ stream >> % 107 0 obj << -/D [909 0 R /XYZ 99.895 718.084 null] +/D [909 0 R /XYZ 99.895 609.837 null] >> % 912 0 obj << -/D [909 0 R /XYZ 99.895 532.185 null] +/D [909 0 R /XYZ 99.895 392.536 null] >> % 111 0 obj << -/D [909 0 R /XYZ 99.895 477.767 null] +/D [909 0 R /XYZ 99.895 328.891 null] >> endstream endobj 916 0 obj << -/Length 4817 +/Length 3707 +>> +stream +0 g 0 G +0 g 0 G +BT +/F27 9.9626 Tf 150.705 706.129 Td [(sizeof)-383(|)-384(Get)-383(memory)-383(o)-32(ccupation)-384(in)-383(b)32(ytes)-384(of)-383(a)-383(sparse)-384(matrix)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 0 -19.674 Td [(memory_size)-525(=)-525(a%sizeof\050\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -23.989 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -22.687 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -22.686 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.355 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ +0 g 0 G + -57.285 -35.944 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -22.687 Td [(F)96(unction)-384(v)64(alue)]TJ +0 g 0 G +/F8 9.9626 Tf 78.386 0 Td [(The)-333(memory)-334(o)-28(ccupation)-333(in)-333(b)28(ytes.)]TJ/F27 9.9626 Tf -78.386 -29.558 Td [(get)]TJ +ET +q +1 0 0 1 166.827 517.148 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 170.264 516.949 Td [(fm)32(t)-383(|)-384(Short)-383(description)-384(of)-383(the)-383(dynamic)-384(t)32(yp)-32(e)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -19.559 -19.675 Td [(write\050*,*\051)-525(a%get_fmt\050\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -23.988 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -22.687 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -22.687 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.355 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ +0 g 0 G + -57.285 -35.944 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -22.686 Td [(F)96(unction)-384(v)64(alue)]TJ +0 g 0 G +/F8 9.9626 Tf 78.386 0 Td [(A)-484(short)-483(string)-484(describing)-484(the)-484(dynamic)-484(t)28(yp)-28(e)-483(of)-484(the)-484(matrix.)]TJ -53.48 -11.956 Td [(Prede\014ned)-333(v)55(alues)-333(include)]TJ/F30 9.9626 Tf 113.409 0 Td [(NULL)]TJ/F8 9.9626 Tf 20.921 0 Td [(,)]TJ/F30 9.9626 Tf 6.088 0 Td [(COO)]TJ/F8 9.9626 Tf 15.691 0 Td [(,)]TJ/F30 9.9626 Tf 6.089 0 Td [(CSR)]TJ/F8 9.9626 Tf 19.012 0 Td [(and)]TJ/F30 9.9626 Tf 19.371 0 Td [(CSC)]TJ/F8 9.9626 Tf 15.691 0 Td [(.)]TJ/F27 9.9626 Tf -241.178 -29.558 Td [(is)]TJ +ET +q +1 0 0 1 159.094 316.012 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 162.531 315.813 Td [(bld,)-383(is)]TJ +ET +q +1 0 0 1 193.834 316.012 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 197.271 315.813 Td [(up)-32(d,)-383(is)]TJ +ET +q +1 0 0 1 232.075 316.012 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 235.512 315.813 Td [(asb)-383(|)-384(Status)-383(c)32(hec)32(k)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -84.807 -19.674 Td [(if)-525(\050a%is_bld\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_upd\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_asb\050\051\051)-525(then)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -23.989 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -22.687 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -22.686 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.356 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.378 0 Td [(lo)-32(cal)]TJ +0 g 0 G + -57.285 -35.944 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -22.686 Td [(F)96(unction)-384(v)64(alue)]TJ +0 g 0 G +/F8 9.9626 Tf 78.386 0 Td [(A)]TJ/F30 9.9626 Tf 9.728 0 Td [(logical)]TJ/F8 9.9626 Tf 38.869 0 Td [(v)56(alue)-227(indicating)-226(whether)-227(the)-226(m)-1(atr)1(ix)-227(is)-227(in)-226(the)-227(Build)1(,)]TJ -102.076 -11.955 Td [(Up)-28(date)-333(or)-333(Assem)27(bled)-333(state,)-333(resp)-28(ectiv)28(e)-1(l)1(y)83(.)]TJ +0 g 0 G + 141.967 -29.888 Td [(18)]TJ +0 g 0 G +ET + +endstream +endobj +920 0 obj +<< +/Length 4601 +>> +stream +0 g 0 G +0 g 0 G +BT +/F27 9.9626 Tf 99.895 706.129 Td [(is)]TJ +ET +q +1 0 0 1 108.284 706.328 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 111.722 706.129 Td [(lo)32(w)32(er,)-383(is)]TJ +ET +q +1 0 0 1 153.63 706.328 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 157.068 706.129 Td [(upp)-32(er,)-383(is)]TJ +ET +q +1 0 0 1 201.841 706.328 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 205.278 706.129 Td [(triangle,)-383(i)-1(s)]TJ +ET +q +1 0 0 1 259.121 706.328 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 262.558 706.129 Td [(unit)-383(|)-384(F)96(ormat)-383(c)32(hec)32(k)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -162.663 -19.048 Td [(if)-525(\050a%is_triangle\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_upper\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_lower\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_unit\050\051\051)-525(then)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -22.979 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -21.341 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -21.34 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ +0 g 0 G + -57.286 -34.934 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -21.341 Td [(F)96(unction)-384(v)64(alue)]TJ +0 g 0 G +/F8 9.9626 Tf 78.387 0 Td [(A)]TJ/F30 9.9626 Tf 10.614 0 Td [(logical)]TJ/F8 9.9626 Tf 39.755 0 Td [(v)56(alue)-316(indicating)-315(whether)-316(the)-315(matrix)-316(is)-315(triangular;)]TJ -103.849 -11.955 Td [(if)]TJ/F30 9.9626 Tf 8.896 0 Td [(is_triangle\050\051)]TJ/F8 9.9626 Tf 71.078 0 Td [(returns)]TJ/F30 9.9626 Tf 34.19 0 Td [(.true.)]TJ/F8 9.9626 Tf 34.466 0 Td [(c)28(hec)27(k)-309(also)-310(if)-309(it)-310(is)-309(lo)28(w)27(er,)-314(upp)-28(er)-309(and)-310(with)]TJ -148.63 -11.955 Td [(a)-333(unit)-334(\050i.e.)-444(assumed\051)-333(diagonal.)]TJ/F27 9.9626 Tf -24.907 -27.773 Td [(cscn)32(v)-383(|)-384(Con)32(v)32(ert)-383(to)-384(a)-383(di\013eren)32(t)-383(storage)-384(format)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 0 -19.048 Td [(call)-1050(a%cscnv\050b,info)-525([,)-525(type,)-525(mold,)-525(dupl]\051)]TJ 0 -11.955 Td [(call)-1050(a%cscnv\050info)-525([,)-525(type,)-525(mold,)-525(dupl]\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -22.979 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -21.34 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -21.341 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.359 -33.295 Td [(t)32(yp)-32(e)]TJ +0 g 0 G +/F8 9.9626 Tf 27.1 0 Td [(a)-333(string)-334(requesting)-333(a)-333(new)-334(format.)]TJ -2.193 -11.956 Td [(T)28(yp)-28(e:)-444(optional.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -21.34 Td [(mold)]TJ +0 g 0 G +/F8 9.9626 Tf 29.805 0 Td [(a)-312(v)56(ariable)-312(of)]TJ/F30 9.9626 Tf 56.396 0 Td [(class\050psb_T_base_sparse_mat\051)]TJ/F8 9.9626 Tf 149.557 0 Td [(requesting)-312(a)-312(new)-312(format.)]TJ -210.851 -11.955 Td [(T)28(yp)-28(e:)-444(optional.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -21.34 Td [(dupl)]TJ +0 g 0 G +/F8 9.9626 Tf 27.259 0 Td [(an)-268(in)28(teger)-268(v)56(alue)-268(sp)-28(eci\014ng)-267(ho)27(w)-267(to)-268(handle)-268(duplicates)-268(\050see)-268(Named)-267(Constan)27(ts)]TJ -2.352 -11.956 Td [(b)-28(elo)28(w\051)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -22.979 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -21.34 Td [(b,a)]TJ +0 g 0 G +/F8 9.9626 Tf 20.098 0 Td [(A)-333(cop)27(y)-333(of)]TJ/F30 9.9626 Tf 45.386 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(with)-333(a)-334(new)-333(storage)-333(format.)]TJ -49.128 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -185.305 -21.34 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ -23.758 -23.333 Td [(The)]TJ/F30 9.9626 Tf 20.085 0 Td [(mold)]TJ/F8 9.9626 Tf 23.848 0 Td [(argumen)28(ts)-294(ma)28(y)-294(b)-28(e)-294(emplo)28(y)28(ed)-294(to)-294(in)28(terface)-294(with)-293(sp)-28(ecial)-294(devices,)-302(suc)28(h)-294(as)]TJ -43.933 -11.955 Td [(GPUs)-333(and)-334(other)-333(accelerators.)]TJ +0 g 0 G + 166.875 -29.888 Td [(19)]TJ +0 g 0 G +ET + +endstream +endobj +925 0 obj +<< +/Length 4076 +>> +stream +0 g 0 G +0 g 0 G +BT +/F27 9.9626 Tf 150.705 706.129 Td [(csclip)-383(|)-384(Reduce)-383(to)-383(a)-384(submatrix)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 20.921 -19.41 Td [(call)-525(a%csclip\050b,info[,&)]TJ 15.691 -11.955 Td [(&)-525(imin,imax,jmin,jmax,rscale,cscale]\051)]TJ/F8 9.9626 Tf -21.668 -24.111 Td [(Returns)-222(the)-222(submatrix)]TJ/F30 9.9626 Tf 99.101 0 Td [(A\050imin:imax,jmin:jmax\051)]TJ/F8 9.9626 Tf 115.067 0 Td [(,)-244(optionally)-222(re)-1(scaling)-222(ro)28(w/-)]TJ -229.112 -11.955 Td [(col)-333(indices)-334(to)-333(the)-333(range)]TJ/F30 9.9626 Tf 104.691 0 Td [(1:imax-imin+1,1:jmax-jmin+1)]TJ/F8 9.9626 Tf 141.219 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -245.91 -21.57 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -22.119 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -22.118 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.956 Td [(A)-333(v)55(ariable)-333(of)-333(t)28(yp)-28(e)]TJ/F30 9.9626 Tf 81.942 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.456 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.378 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.358 -34.073 Td [(imin,imax,jmin,jmax)]TJ +0 g 0 G +/F8 9.9626 Tf 108.412 0 Td [(Minim)28(um)-334(an)1(d)-334(maxim)28(um)-333(ro)27(w)-333(and)-333(column)-333(indices)-1(.)]TJ -83.505 -11.956 Td [(T)28(yp)-28(e:)-444(optional.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -22.118 Td [(rscale,cscale)]TJ +0 g 0 G +/F8 9.9626 Tf 65.202 0 Td [(Whether)-333(to)-334(rescale)-333(ro)28(w/column)-334(indices.)-444(T)28(yp)-28(e:)-445(op)1(tional.)]TJ +0 g 0 G +/F27 9.9626 Tf -65.202 -24.111 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -22.118 Td [(b)]TJ +0 g 0 G +/F8 9.9626 Tf 11.346 0 Td [(A)-333(cop)27(y)-333(of)-333(a)-334(submatri)1(x)-334(of)]TJ/F30 9.9626 Tf 112.44 0 Td [(a)]TJ/F8 9.9626 Tf 5.23 0 Td [(.)]TJ -104.109 -11.956 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(y)1(p)-28(e)]TJ/F30 9.9626 Tf 81.942 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.456 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -185.305 -22.118 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -28.805 Td [(clean)]TJ +ET +q +1 0 0 1 176.852 371.924 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 180.289 371.725 Td [(zeros)-383(|)-384(Eliminate)-383(zero)-383(c)-1(o)-31(e\016ci)-1(e)1(n)31(ts)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -8.663 -19.41 Td [(call)-525(a%clean_zeros\050info\051)]TJ/F8 9.9626 Tf -5.977 -24.111 Td [(Eliminates)-285(zero)-284(co)-28(e\016cien)27(ts)-284(in)-285(the)-285(i)1(nput)-285(matrix.)-428(Note)-285(that)-285(dep)-27(ending)-285(on)-284(the)]TJ -14.944 -11.955 Td [(in)28(ternal)-333(storage)-333(format,)-333(there)-334(ma)28(y)-333(still)-333(b)-28(e)-333(some)-333(amoun)28(t)-333(of)-334(zero)-333(padding)-333(in)-333(the)]TJ 0 -11.955 Td [(output.)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -24.111 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -22.119 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -22.118 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.355 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.358 -35.518 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -22.119 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.55 0 Td [(The)-333(matrix)]TJ/F30 9.9626 Tf 52.886 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(without)-333(zero)-334(co)-27(e\016)-1(cien)28(ts.)]TJ -47.081 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -185.304 -22.118 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ +0 g 0 G + 143.116 -29.888 Td [(20)]TJ +0 g 0 G +ET + +endstream +endobj +929 0 obj +<< +/Length 4032 +>> +stream +0 g 0 G +0 g 0 G +BT +/F27 9.9626 Tf 99.895 706.129 Td [(get)]TJ +ET +q +1 0 0 1 116.018 706.328 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 119.455 706.129 Td [(diag)-383(|)-384(Get)-383(main)-383(diagonal)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 1.362 -18.389 Td [(call)-525(a%get_diag\050d,info\051)]TJ/F8 9.9626 Tf -5.978 -21.799 Td [(Returns)-333(a)-334(cop)28(y)-333(of)-334(th)1(e)-334(main)-333(diagonal.)]TJ +0 g 0 G +/F27 9.9626 Tf -14.944 -19.829 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -19.878 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -19.877 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.956 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.359 -33.753 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -19.878 Td [(d)]TJ +0 g 0 G +/F8 9.9626 Tf 11.347 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-333(m)-1(ai)1(n)-334(diagonal.)]TJ 13.56 -11.955 Td [(A)-333(one-dimensional)-334(arra)28(y)-333(of)-333(the)-334(appropriate)-333(t)28(yp)-28(e.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -19.877 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -25.876 Td [(clip)]TJ +ET +q +1 0 0 1 118.405 471.307 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.842 471.107 Td [(diag)-383(|)-384(Cut)-383(out)-383(main)-384(diagonal)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -1.025 -18.389 Td [(call)-525(a%clip_diag\050b,info\051)]TJ/F8 9.9626 Tf -5.978 -21.798 Td [(Returns)-333(a)-334(cop)28(y)-333(of)]TJ/F30 9.9626 Tf 80.753 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(without)-333(the)-334(main)-333(diagonal.)]TJ +0 g 0 G +/F27 9.9626 Tf -104.248 -19.83 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -19.877 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -19.878 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.359 -33.754 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -19.877 Td [(b)]TJ +0 g 0 G +/F8 9.9626 Tf 11.347 0 Td [(A)-333(cop)27(y)-333(of)]TJ/F30 9.9626 Tf 45.385 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(without)-333(the)-334(main)-333(diagonal.)]TJ -40.376 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -185.305 -19.878 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -25.875 Td [(tril)-383(|)-384(Return)-383(the)-383(lo)31(w)32(er)-383(triangle)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 20.922 -18.389 Td [(call)-525(a%tril\050l,info[,&)]TJ 15.691 -11.956 Td [(&)-525(diag,imin,imax,jmin,jmax,rscale,cscale,u]\051)]TJ/F8 9.9626 Tf -21.669 -21.798 Td [(Returns)-376(the)-376(lo)28(w)28(er)-376(triangular)-376(p)1(art)-376(of)-376(submatrix)]TJ/F30 9.9626 Tf 210.933 0 Td [(A\050imin:imax,jmin:jmax\051)]TJ/F8 9.9626 Tf 115.067 0 Td [(,)]TJ -340.944 -11.955 Td [(optionally)-222(rescaling)-222(ro)27(w/col)-222(indices)-222(to)-222(the)-222(range)]TJ/F30 9.9626 Tf 205.536 0 Td [(1:imax-imin+1,1:jmax-jmin+1)]TJ/F8 9.9626 Tf -205.536 -11.955 Td [(and)-333(returing)-334(th)1(e)-334(complemen)28(tary)-333(upp)-28(er)-333(triangle.)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -19.83 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -19.877 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G +/F8 9.9626 Tf 166.875 -29.888 Td [(21)]TJ +0 g 0 G +ET + +endstream +endobj +933 0 obj +<< +/Length 5513 +>> +stream +0 g 0 G +0 g 0 G +0 g 0 G +BT +/F27 9.9626 Tf 150.705 706.129 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.355 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.358 -30.78 Td [(diag)]TJ +0 g 0 G +/F8 9.9626 Tf 25.826 0 Td [(Include)-392(diagonals)-391(up)-392(to)-392(this)-391(o)-1(n)1(e)-1(;)]TJ/F30 9.9626 Tf 149.735 0 Td [(diag=1)]TJ/F8 9.9626 Tf 35.285 0 Td [(means)-392(the)-392(\014)1(rs)-1(t)-391(sup)-28(erdiagonal,)]TJ/F30 9.9626 Tf -185.94 -11.955 Td [(diag=-1)]TJ/F8 9.9626 Tf 39.934 0 Td [(means)-333(the)-334(\014rst)-333(sub)-28(diagonal.)-444(Default)-333(0.)]TJ +0 g 0 G +/F27 9.9626 Tf -64.84 -18.824 Td [(imin,imax,jmin,jmax)]TJ +0 g 0 G +/F8 9.9626 Tf 108.412 0 Td [(Minim)28(um)-333(and)-334(maxim)28(um)-333(ro)27(w)-333(and)-333(column)-333(indices.)]TJ -83.506 -11.955 Td [(T)28(yp)-28(e:)-444(optional.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.906 -18.824 Td [(rscale,cscale)]TJ +0 g 0 G +/F8 9.9626 Tf 65.202 0 Td [(Whether)-333(to)-334(rescale)-333(ro)28(w/column)-334(indices.)-444(T)28(yp)-28(e:)-445(op)1(tional.)]TJ +0 g 0 G +/F27 9.9626 Tf -65.202 -19.165 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -18.824 Td [(l)]TJ +0 g 0 G +/F8 9.9626 Tf 8.164 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-333(lo)27(w)28(er)-333(triangle)-334(of)]TJ/F30 9.9626 Tf 136.488 0 Td [(a)]TJ/F8 9.9626 Tf 5.23 0 Td [(.)]TJ -124.976 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -185.304 -18.824 Td [(u)]TJ +0 g 0 G +/F8 9.9626 Tf 11.346 0 Td [(\050optional\051)-333(A)-334(cop)28(y)-333(of)-333(the)-334(upp)-27(er)-334(triangle)-333(of)]TJ/F30 9.9626 Tf 185.472 0 Td [(a)]TJ/F8 9.9626 Tf 5.23 0 Td [(.)]TJ -177.142 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -185.304 -18.825 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -25.421 Td [(triu)-383(|)-384(Return)-383(the)-383(upp)-32(er)-384(triangle)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 20.921 -18.39 Td [(call)-525(a%triu\050u,info[,&)]TJ 15.691 -11.955 Td [(&)-525(diag,imin,imax,jmin,jmax,rscale,cscale,l]\051)]TJ/F8 9.9626 Tf -21.668 -19.165 Td [(Returns)-340(the)-340(upp)-28(er)-340(triangular)-340(part)-340(of)-340(submatrix)]TJ/F30 9.9626 Tf 210.932 0 Td [(A\050imin:imax,jmin:jmax\051)]TJ/F8 9.9626 Tf 115.067 0 Td [(,)]TJ -340.943 -11.955 Td [(optionally)-222(rescaling)-222(ro)28(w)-1(/col)-222(indices)-222(to)-222(the)-222(range)]TJ/F30 9.9626 Tf 205.535 0 Td [(1:imax-imin+1,1:jmax-jmin+1)]TJ/F8 9.9626 Tf 141.219 0 Td [(,)]TJ -346.754 -11.955 Td [(and)-333(returing)-333(the)-334(complemen)28(tary)-333(lo)27(w)28(er)-333(triangle.)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -17.723 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -18.824 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -18.824 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.55 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.358 -30.78 Td [(diag)]TJ +0 g 0 G +/F8 9.9626 Tf 25.826 0 Td [(Include)-392(diagonals)-391(up)-392(to)-392(this)-391(o)-1(n)1(e)-1(;)]TJ/F30 9.9626 Tf 149.735 0 Td [(diag=1)]TJ/F8 9.9626 Tf 35.285 0 Td [(means)-392(the)-392(\014)1(rs)-1(t)-391(sup)-28(erdiagonal,)]TJ/F30 9.9626 Tf -185.94 -11.955 Td [(diag=-1)]TJ/F8 9.9626 Tf 39.934 0 Td [(means)-333(the)-334(\014rst)-333(sub)-28(diagonal.)-444(Default)-333(0.)]TJ +0 g 0 G +/F27 9.9626 Tf -64.84 -18.824 Td [(imin,imax,jmin,jmax)]TJ +0 g 0 G +/F8 9.9626 Tf 108.412 0 Td [(Minim)28(um)-333(and)-334(maxim)28(um)-333(ro)27(w)-333(and)-333(column)-333(indices.)]TJ -83.506 -11.955 Td [(T)28(yp)-28(e:)-444(optional.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.906 -18.824 Td [(rscale,cscale)]TJ +0 g 0 G +/F8 9.9626 Tf 65.202 0 Td [(Whether)-333(to)-334(rescale)-333(ro)28(w/column)-334(indices.)-444(T)28(yp)-28(e:)-445(op)1(tional.)]TJ +0 g 0 G +/F27 9.9626 Tf -65.202 -19.165 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -18.824 Td [(u)]TJ +0 g 0 G +/F8 9.9626 Tf 11.346 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-334(u)1(pp)-28(er)-334(tr)1(iangle)-334(of)]TJ/F30 9.9626 Tf 138.979 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ -130.65 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -185.304 -18.824 Td [(l)]TJ +0 g 0 G +/F8 9.9626 Tf 8.164 0 Td [(\050optional\051)-333(A)-333(c)-1(op)28(y)-333(of)-333(the)-334(lo)28(w)28(er)-333(triangle)-334(of)]TJ/F30 9.9626 Tf 182.98 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ -171.469 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -185.304 -18.824 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ +0 g 0 G + 143.116 -29.888 Td [(22)]TJ +0 g 0 G +ET + +endstream +endobj +939 0 obj +<< +/Length 7706 +>> +stream +0 g 0 G +0 g 0 G +BT +/F27 9.9626 Tf 99.895 706.129 Td [(psb)]TJ +ET +q +1 0 0 1 117.832 706.328 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.269 706.129 Td [(set)]TJ +ET +q +1 0 0 1 136.182 706.328 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 139.619 706.129 Td [(mat)]TJ +ET +q +1 0 0 1 159.879 706.328 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 163.316 706.129 Td [(default)-383(|)-384(Set)-383(default)-383(storage)-384(format)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -63.421 -18.389 Td [(call)-1050(psb_set_mat_default\050a\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -20.935 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -19.532 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -19.532 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(a)-285(v)56(ariable)-285(of)]TJ/F30 9.9626 Tf 55.581 0 Td [(class\050psb_T_base_sparse_mat\051)]TJ/F8 9.9626 Tf 149.286 0 Td [(requesting)-285(a)-284(new)-285(default)-284(s)-1(t)1(or-)]TJ -190.511 -11.955 Td [(age)-333(format.)]TJ 0 -11.956 Td [(T)28(yp)-28(e:)-444(required.)]TJ/F27 9.9626 Tf -24.907 -25.726 Td [(clone)-383(|)-384(Clone)-383(curren)32(t)-383(ob)-64(ject)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 0 -18.389 Td [(call)-1050(a%clone\050b,info\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -20.935 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -19.532 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -19.532 Td [(a)]TJ +0 g 0 G +/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -80.359 -32.89 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -19.532 Td [(b)]TJ +0 g 0 G +/F8 9.9626 Tf 11.347 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-333(input)-334(ob)-55(ject.)]TJ +0 g 0 G +/F27 9.9626 Tf -11.347 -19.532 Td [(info)]TJ +0 g 0 G +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -25.727 Td [(3.2.2)-1150(Named)-383(Constan)31(ts)]TJ +0 g 0 G + 0 -18.389 Td [(psb)]TJ +ET +q +1 0 0 1 117.832 371.89 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.269 371.691 Td [(dupl)]TJ +ET +q +1 0 0 1 144.234 371.89 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 147.671 371.691 Td [(o)32(vwrt)]TJ +ET +q +1 0 0 1 177.264 371.89 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +0 g 0 G +BT +/F8 9.9626 Tf 185.682 371.691 Td [(Duplicate)-315(co)-28(e\016cien)28(ts)-315(should)-315(b)-28(e)-315(o)28(v)28(erwritten)-315(\050i.e.)-438(ignore)-315(du-)]TJ -60.88 -11.955 Td [(plications\051)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -19.532 Td [(psb)]TJ +ET +q +1 0 0 1 117.832 340.403 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.269 340.204 Td [(dupl)]TJ +ET +q +1 0 0 1 144.234 340.403 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 147.671 340.204 Td [(add)]TJ +ET +q +1 0 0 1 166.658 340.403 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +0 g 0 G +BT +/F8 9.9626 Tf 175.076 340.204 Td [(Duplicate)-333(co)-28(e\016cien)28(ts)-334(should)-333(b)-28(e)-333(added;)]TJ +0 g 0 G +/F27 9.9626 Tf -75.181 -19.532 Td [(psb)]TJ +ET +q +1 0 0 1 117.832 320.871 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.269 320.672 Td [(dupl)]TJ +ET +q +1 0 0 1 144.234 320.871 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 147.671 320.672 Td [(err)]TJ +ET +q +1 0 0 1 163.046 320.871 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +0 g 0 G +BT +/F8 9.9626 Tf 171.465 320.672 Td [(Duplicate)-333(co)-28(e\016cien)28(ts)-334(should)-333(trigger)-333(an)-334(error)-333(conditino)]TJ +0 g 0 G +/F27 9.9626 Tf -71.57 -19.532 Td [(psb)]TJ +ET +q +1 0 0 1 117.832 301.339 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.269 301.14 Td [(up)-32(d)]TJ +ET +q +1 0 0 1 141.37 301.339 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 144.807 301.14 Td [(d\015t)]TJ +ET +q +1 0 0 1 162.68 301.339 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +0 g 0 G +BT +/F8 9.9626 Tf 171.098 301.14 Td [(Default)-333(up)-28(date)-333(strategy)-334(for)-333(matrix)-333(co)-28(e\016cien)28(ts;)]TJ +0 g 0 G +/F27 9.9626 Tf -71.203 -19.533 Td [(psb)]TJ +ET +q +1 0 0 1 117.832 281.807 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.269 281.607 Td [(up)-32(d)]TJ +ET +q +1 0 0 1 141.37 281.807 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 144.807 281.607 Td [(src)32(h)]TJ +ET +q +1 0 0 1 165.87 281.807 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +0 g 0 G +BT +/F8 9.9626 Tf 174.289 281.607 Td [(Up)-28(date)-333(strategy)-333(based)-334(on)-333(searc)28(h)-334(in)28(to)-333(the)-334(d)1(ata)-334(structure;)]TJ +0 g 0 G +/F27 9.9626 Tf -74.394 -19.532 Td [(psb)]TJ +ET +q +1 0 0 1 117.832 262.275 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 121.269 262.075 Td [(up)-32(d)]TJ +ET +q +1 0 0 1 141.37 262.275 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 144.807 262.075 Td [(p)-32(erm)]TJ +ET +q +1 0 0 1 171.694 262.275 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +0 g 0 G +BT +/F8 9.9626 Tf 180.113 262.075 Td [(Up)-28(date)-398(strategy)-398(based)-398(on)-398(additional)-398(p)-28(erm)28(utation)-398(data)-398(\050se)-1(e)]TJ -55.311 -11.955 Td [(to)-28(ols)-333(routine)-333(description\051.)]TJ/F16 11.9552 Tf -24.907 -27.719 Td [(3.3)-1125(Dense)-375(V)94(ector)-375(Data)-375(Structure)]TJ/F8 9.9626 Tf 0 -18.389 Td [(The)]TJ/F30 9.9626 Tf 21.256 0 Td [(psb)]TJ +ET +q +1 0 0 1 137.47 204.211 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 140.608 204.012 Td [(T)]TJ +ET +q +1 0 0 1 146.466 204.211 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 149.604 204.012 Td [(vect)]TJ +ET +q +1 0 0 1 171.153 204.211 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 174.291 204.012 Td [(type)]TJ/F8 9.9626 Tf 25.02 0 Td [(data)-411(structure)-412(encapsulates)-411(the)-411(dense)-412(v)28(ectors)-411(in)-412(a)-411(w)28(a)28(y)]TJ -99.416 -11.955 Td [(similar)-434(to)-435(sparse)-434(matrices,)-459(i.e.)-748(includ)1(ing)-435(a)-434(base)-434(t)28(yp)-28(e)]TJ/F30 9.9626 Tf 242.195 0 Td [(psb)]TJ +ET +q +1 0 0 1 358.409 192.256 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 361.547 192.057 Td [(T)]TJ +ET +q +1 0 0 1 367.405 192.256 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 370.543 192.057 Td [(base)]TJ +ET +q +1 0 0 1 392.092 192.256 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 395.231 192.057 Td [(vect)]TJ +ET +q +1 0 0 1 416.779 192.256 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 419.918 192.057 Td [(type)]TJ/F8 9.9626 Tf 20.921 0 Td [(.)]TJ -340.944 -11.956 Td [(The)-330(user)-330(will)-330(not,)-330(in)-330(general,)-331(access)-330(the)-330(v)28(ector)-330(comp)-28(onen)28(ts)-330(directly)83(,)-330(but)-330(rather)]TJ 0 -11.955 Td [(via)-303(the)-304(routi)1(ne)-1(s)-303(of)-303(sec.)]TJ +0 0 1 rg 0 0 1 RG + [-304(6)]TJ +0 g 0 G + [(.)-434(Among)-303(other)-303(s)-1(impl)1(e)-304(things,)-309(w)28(e)-304(de\014ne)-303(here)-303(an)-303(e)-1(xtr)1(ac)-1(-)]TJ 0 -11.955 Td [(tion)-321(metho)-28(d)-320(that)-321(can)-321(b)-27(e)-321(used)-321(to)-321(get)-321(a)-320(full)-321(cop)28(y)-321(of)-321(the)-320(part)-321(of)-321(the)-320(v)27(ector)-320(s)-1(t)1(o)-1(r)1(e)-1(d)]TJ 0 -11.955 Td [(on)-333(the)-334(lo)-27(cal)-334(pro)-27(c)-1(ess.)]TJ 14.944 -11.955 Td [(The)-399(t)28(yp)-28(e)-399(declaration)-398(is)-399(sho)28(w)-1(n)-398(in)-399(\014gure)]TJ +0 0 1 rg 0 0 1 RG + [-399(5)]TJ +0 g 0 G + [-399(where)]TJ/F30 9.9626 Tf 216.941 0 Td [(T)]TJ/F8 9.9626 Tf 9.203 0 Td [(is)-399(a)-399(placeholder)-398(for)-399(the)]TJ -241.088 -11.955 Td [(data)-333(t)27(yp)-27(e)-334(and)-333(precision)-333(v)55(arian)28(ts)]TJ +0 g 0 G + 166.875 -29.888 Td [(23)]TJ +0 g 0 G +ET + +endstream +endobj +945 0 obj +<< +/Length 3700 +>> +stream +0 g 0 G +0 g 0 G +0 g 0 G +BT +/F27 9.9626 Tf 150.705 706.129 Td [(I)]TJ +0 g 0 G +/F8 9.9626 Tf 9.326 0 Td [(In)28(teger;)]TJ +0 g 0 G +/F27 9.9626 Tf -9.326 -21.082 Td [(S)]TJ +0 g 0 G +/F8 9.9626 Tf 11.346 0 Td [(Single)-333(precision)-334(real;)]TJ +0 g 0 G +/F27 9.9626 Tf -11.346 -21.083 Td [(D)]TJ +0 g 0 G +/F8 9.9626 Tf 13.768 0 Td [(Double)-333(precision)-334(real;)]TJ +0 g 0 G +/F27 9.9626 Tf -13.768 -21.082 Td [(C)]TJ +0 g 0 G +/F8 9.9626 Tf 13.256 0 Td [(Single)-333(precision)-334(complex;)]TJ +0 g 0 G +/F27 9.9626 Tf -13.256 -21.083 Td [(Z)]TJ +0 g 0 G +/F8 9.9626 Tf 11.983 0 Td [(Double)-333(precision)-334(complex.)]TJ -11.983 -20.793 Td [(The)-280(ac)-1(tu)1(al)-281(data)-280(is)-281(con)28(tained)-280(in)-281(the)-280(p)-28(olymorphic)-280(c)-1(omp)-27(onen)28(t)]TJ/F30 9.9626 Tf 260.737 0 Td [(v%v)]TJ/F8 9.9626 Tf 15.691 0 Td [(;)-298(the)-280(s)-1(eparati)1(on)]TJ -276.428 -11.955 Td [(b)-28(et)28(w)28(een)-427(the)-426(application)-427(and)-426(the)-427(actual)-426(data)-426(is)-427(essen)28(tial)-427(for)-426(cases)-427(where)-426(it)-427(is)]TJ 0 -11.955 Td [(necessary)-426(to)-426(link)-425(to)-426(data)-426(storage)-426(made)-425(a)27(v)56(ailable)-426(elsewhere)-426(outside)-425(the)-426(direct)]TJ 0 -11.955 Td [(con)28(trol)-335(of)-335(the)-336(compiler/appl)1(ic)-1(ati)1(on,)-336(e.g.)-450(data)-335(stored)-335(in)-335(a)-335(graphics)-335(ac)-1(celerator's)]TJ 0 -11.955 Td [(priv)56(ate)-334(memory)84(.)]TJ +0 g 0 G +0 g 0 G +0 g 0 G +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 36.238 -20.559 Td [(type)-525(psb_T_base_vect_type)]TJ 10.461 -11.956 Td [(TYPE\050KIND_\051,)-525(allocatable)-525(::)-525(v\050:\051)]TJ -10.461 -11.955 Td [(end)-525(type)-525(psb_T_base_vect_type)]TJ 0 -23.91 Td [(type)-525(psb_T_vect_type)]TJ 10.461 -11.955 Td [(class\050psb_T_base_vect_type\051,)-525(allocatable)-525(::)-525(v)]TJ -10.461 -11.956 Td [(end)-525(type)-1050(psb_T_vect_type)]TJ +0 g 0 G +/F8 9.9626 Tf -22.069 -39.795 Td [(Figure)-333(5:)-889(The)-333(PSBLAS)-334(de\014ned)-333(data)-333(t)27(y)1(p)-28(e)-334(that)-333(con)28(tains)-333(a)-334(dense)-333(v)28(ector.)]TJ +0 g 0 G +0 g 0 G +/F27 9.9626 Tf -14.169 -39.964 Td [(3.3.1)-1150(V)96(ector)-384(Metho)-32(ds)]TJ 0 -18.928 Td [(get)]TJ +ET +q +1 0 0 1 166.827 362.408 cm +[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S +Q +BT +/F27 9.9626 Tf 170.264 362.208 Td [(nro)32(ws)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(ro)32(ws)-383(in)-383(a)-384(dense)-383(v)32(ector)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf -19.559 -18.927 Td [(nr)-525(=)-525(v%get_nrows\050\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -22.786 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -21.082 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -21.083 Td [(v)]TJ +0 g 0 G +/F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector)]TJ 13.878 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ +0 g 0 G + -57.285 -34.741 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -21.082 Td [(F)96(unction)-384(v)64(alue)]TJ +0 g 0 G +/F8 9.9626 Tf 78.386 0 Td [(The)-333(n)27(um)28(b)-28(er)-333(of)-333(ro)28(ws)-334(of)-333(dense)-333(v)27(ector)]TJ/F30 9.9626 Tf 159.596 0 Td [(v)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ/F27 9.9626 Tf -243.213 -27.431 Td [(sizeof)-383(|)-384(Get)-383(memory)-383(o)-32(ccupation)-384(in)-383(b)32(ytes)-384(of)-383(a)-383(dense)-384(v)32(ector)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 0 -18.927 Td [(memory_size)-525(=)-525(v%sizeof\050\051)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -22.786 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -21.082 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G +/F8 9.9626 Tf 166.874 -29.888 Td [(24)]TJ +0 g 0 G +ET + +endstream +endobj +951 0 obj +<< +/Length 3837 +>> +stream +0 g 0 G +0 g 0 G +0 g 0 G +BT +/F27 9.9626 Tf 99.895 706.129 Td [(v)]TJ +0 g 0 G +/F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector)]TJ 13.879 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ +0 g 0 G + -57.286 -37.007 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -24.103 Td [(F)96(unction)-384(v)64(alue)]TJ +0 g 0 G +/F8 9.9626 Tf 78.387 0 Td [(The)-333(memory)-334(o)-28(ccupati)1(on)-334(in)-333(b)28(ytes.)]TJ/F27 9.9626 Tf -78.387 -31.438 Td [(set)-383(|)-384(Set)-383(con)32(ten)32(ts)-383(of)-384(the)-383(v)32(ector)]TJ +0 g 0 G +0 g 0 G +/F30 9.9626 Tf 5.231 -20.333 Td [(call)-1050(v%set\050alpha[,first,last]\051)]TJ 0 -11.955 Td [(call)-1050(v%set\050vect[,first,last]\051)]TJ 0 -11.956 Td [(call)-1050(v%zero\050\051)]TJ +0 g 0 G +/F27 9.9626 Tf -5.231 -25.051 Td [(T)32(yp)-32(e:)]TJ +0 g 0 G +/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ +0 g 0 G +/F27 9.9626 Tf -33.797 -24.103 Td [(On)-383(En)32(try)]TJ +0 g 0 G +0 g 0 G + 0 -24.104 Td [(v)]TJ +0 g 0 G +/F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector)]TJ 13.879 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ +0 g 0 G + -57.286 -36.059 Td [(alpha)]TJ +0 g 0 G +/F8 9.9626 Tf 32.033 0 Td [(A)-333(scalar)-334(v)56(alue.)]TJ -7.126 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf -29.611 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(n)28(um)28(b)-28(er)-333(of)-334(the)-333(data)-333(t)28(yp)-28(e)-334(ind)1(ic)-1(ated)-333(in)-333(T)83(able)]TJ +0 0 1 rg 0 0 1 RG + [-333(1)]TJ +0 g 0 G + [(.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -24.104 Td [(\014rst,last)]TJ +0 g 0 G +/F8 9.9626 Tf 45.949 0 Td [(Boundaries)-333(for)-334(setting)-333(in)-333(the)-333(v)27(ector.)]TJ -21.042 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(optional)]TJ/F8 9.9626 Tf -29.611 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(in)28(tegers.)]TJ +0 g 0 G +/F27 9.9626 Tf -24.907 -24.104 Td [(v)32(ect)]TJ +0 g 0 G +/F8 9.9626 Tf 25.509 0 Td [(An)-333(arra)28(y)]TJ -0.602 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf -29.611 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.956 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(n)28(um)28(b)-28(er)-333(of)-334(the)-333(data)-333(t)28(yp)-28(e)-334(ind)1(ic)-1(ated)-333(in)-333(T)83(able)]TJ +0 0 1 rg 0 0 1 RG + [-333(1)]TJ +0 g 0 G + [(.)]TJ -24.907 -26.095 Td [(Note)-392(t)1(hat)-392(a)-391(call)-392(to)]TJ/F30 9.9626 Tf 87.3 0 Td [(v%zero\050\051)]TJ/F8 9.9626 Tf 45.742 0 Td [(is)-391(pro)27(vided)-391(as)-391(a)-392(shorthand,)-406(but)-391(is)-391(equiv)55(alen)28(t)-391(to)]TJ -133.042 -11.956 Td [(a)-320(call)-319(to)]TJ/F30 9.9626 Tf 38.336 0 Td [(v%set\050zero\051)]TJ/F8 9.9626 Tf 60.718 0 Td [(with)-320(the)]TJ/F30 9.9626 Tf 39.579 0 Td [(zero)]TJ/F8 9.9626 Tf 24.106 0 Td [(constan)28(t)-320(ha)28(ving)-320(the)-319(appropriate)-320(t)28(yp)-28(e)-320(and)]TJ -162.739 -11.955 Td [(kind.)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -26.096 Td [(On)-383(Return)]TJ +0 g 0 G +0 g 0 G + 0 -24.103 Td [(v)]TJ +0 g 0 G +/F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector,)-333(with)-334(up)-27(dated)-334(en)28(tries)]TJ 13.879 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ +0 g 0 G +/F8 9.9626 Tf 109.589 -41.843 Td [(25)]TJ +0 g 0 G +ET + +endstream +endobj +959 0 obj +<< +/Length 4652 >> stream 0 g 0 G @@ -6714,1042 +7590,169 @@ q []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 170.264 706.129 Td [(fm)32(t)-383(|)-384(Short)-383(description)-384(of)-383(the)-383(dynamic)-384(t)32(yp)-32(e)]TJ +/F27 9.9626 Tf 170.264 706.129 Td [(v)32(ect)-383(|)-384(Get)-383(a)-383(cop)31(y)-383(of)-383(the)-384(v)32(ector)-383(con)32(ten)32(ts)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -19.559 -18.389 Td [(write\050*,*\051)-525(a%get_fmt\050\051)]TJ +/F30 9.9626 Tf -19.559 -19.197 Td [(extv)-525(=)-525(v%get_vect\050[n]\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -20.78 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -23.219 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -19.47 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -21.66 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -19.47 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.355 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ -0 g 0 G - -57.285 -32.735 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -19.47 Td [(F)96(unction)-384(v)64(alue)]TJ -0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(A)-484(short)-483(string)-484(describing)-484(the)-484(dynamic)-484(t)28(yp)-28(e)-483(of)-484(the)-484(matrix.)]TJ -53.48 -11.955 Td [(Prede\014ned)-333(v)55(alues)-333(include)]TJ/F30 9.9626 Tf 113.409 0 Td [(NULL)]TJ/F8 9.9626 Tf 20.921 0 Td [(,)]TJ/F30 9.9626 Tf 6.088 0 Td [(COO)]TJ/F8 9.9626 Tf 15.691 0 Td [(,)]TJ/F30 9.9626 Tf 6.089 0 Td [(CSR)]TJ/F8 9.9626 Tf 19.012 0 Td [(and)]TJ/F30 9.9626 Tf 19.371 0 Td [(CSC)]TJ/F8 9.9626 Tf 15.691 0 Td [(.)]TJ/F27 9.9626 Tf -241.178 -25.7 Td [(is)]TJ -ET -q -1 0 0 1 159.094 526.404 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 162.531 526.205 Td [(bld,)-383(is)]TJ -ET -q -1 0 0 1 193.834 526.404 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 197.271 526.205 Td [(up)-32(d,)-383(is)]TJ -ET -q -1 0 0 1 232.075 526.404 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 235.512 526.205 Td [(asb)-383(|)-384(Status)-383(c)32(hec)32(k)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf -84.807 -18.39 Td [(if)-525(\050a%is_bld\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_upd\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_asb\050\051\051)-525(then)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -20.78 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.47 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -19.47 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.378 0 Td [(lo)-32(cal)]TJ -0 g 0 G - -57.285 -32.735 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -19.47 Td [(F)96(unction)-384(v)64(alue)]TJ -0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(A)]TJ/F30 9.9626 Tf 9.728 0 Td [(logical)]TJ/F8 9.9626 Tf 38.869 0 Td [(v)56(alue)-227(indicating)-226(whether)-227(the)-226(m)-1(atr)1(ix)-227(is)-227(in)-226(the)-227(Build)1(,)]TJ -102.076 -11.955 Td [(Up)-28(date)-333(or)-333(Assem)27(bled)-333(state,)-333(resp)-28(ectiv)28(e)-1(l)1(y)83(.)]TJ/F27 9.9626 Tf -24.907 -25.7 Td [(is)]TJ -ET -q -1 0 0 1 159.094 322.57 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 162.531 322.37 Td [(lo)32(w)32(er,)-383(i)-1(s)]TJ -ET -q -1 0 0 1 204.44 322.57 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 207.877 322.37 Td [(upp)-32(er,)-383(is)]TJ -ET -q -1 0 0 1 252.65 322.57 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 256.087 322.37 Td [(triangle,)-384(is)]TJ -ET -q -1 0 0 1 309.931 322.57 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 313.368 322.37 Td [(unit)-383(|)-384(F)96(ormat)-383(c)32(hec)32(k)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf -162.663 -18.389 Td [(if)-525(\050a%is_triangle\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_upper\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_lower\050\051\051)-525(then)]TJ 0 -11.955 Td [(if)-525(\050a%is_unit\050\051\051)-525(then)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -20.78 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.47 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -19.47 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.378 0 Td [(lo)-32(cal)]TJ -0 g 0 G - -57.285 -32.735 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -19.47 Td [(F)96(unction)-384(v)64(alue)]TJ -0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(A)]TJ/F30 9.9626 Tf 10.615 0 Td [(logical)]TJ/F8 9.9626 Tf 39.755 0 Td [(v)56(alue)-316(indicating)-315(whether)-316(the)-315(matrix)-316(i)1(s)-316(triangular;)]TJ -103.849 -11.955 Td [(if)]TJ/F30 9.9626 Tf 8.895 0 Td [(is_triangle\050\051)]TJ/F8 9.9626 Tf 71.079 0 Td [(returns)]TJ/F30 9.9626 Tf 34.189 0 Td [(.true.)]TJ/F8 9.9626 Tf 34.466 0 Td [(c)28(hec)27(k)-309(also)-310(if)-309(it)-310(is)-309(lo)27(w)28(er,)-314(upp)-28(er)-309(and)-310(with)]TJ -148.629 -11.955 Td [(a)-333(unit)-334(\050i)1(.e)-1(.)-444(assumed\051)-333(diagonal.)]TJ -0 g 0 G - 141.967 -29.888 Td [(18)]TJ -0 g 0 G -ET - -endstream -endobj -920 0 obj -<< -/Length 4390 ->> -stream -0 g 0 G -0 g 0 G -BT -/F27 9.9626 Tf 99.895 706.129 Td [(cscn)32(v)-383(|)-384(Con)32(v)32(ert)-383(to)-384(a)-383(di\013eren)32(t)-383(storage)-384(format)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 0 -18.389 Td [(call)-1050(a%cscnv\050b,info)-525([,)-525(type,)-525(mold,)-525(dupl]\051)]TJ 0 -11.956 Td [(call)-1050(a%cscnv\050info)-525([,)-525(type,)-525(mold,)-525(dupl]\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -21.446 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.737 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -19.736 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.359 -31.691 Td [(t)32(yp)-32(e)]TJ -0 g 0 G -/F8 9.9626 Tf 27.1 0 Td [(a)-333(string)-334(requesting)-333(a)-333(new)-334(format.)]TJ -2.193 -11.956 Td [(T)28(yp)-28(e:)-444(optional.)]TJ -0 g 0 G -/F27 9.9626 Tf -24.907 -19.736 Td [(mold)]TJ -0 g 0 G -/F8 9.9626 Tf 29.805 0 Td [(a)-312(v)56(ariable)-312(of)]TJ/F30 9.9626 Tf 56.396 0 Td [(class\050psb_T_base_sparse_mat\051)]TJ/F8 9.9626 Tf 149.557 0 Td [(requesting)-312(a)-312(new)-312(format.)]TJ -210.851 -11.955 Td [(T)28(yp)-28(e:)-444(optional.)]TJ -0 g 0 G -/F27 9.9626 Tf -24.907 -19.737 Td [(dupl)]TJ -0 g 0 G -/F8 9.9626 Tf 27.259 0 Td [(an)-268(in)28(teger)-268(v)56(alue)-268(sp)-28(eci\014ng)-267(ho)27(w)-267(to)-268(handle)-268(duplicates)-268(\050see)-268(Named)-267(Constan)27(ts)]TJ -2.352 -11.955 Td [(b)-28(elo)28(w\051)]TJ -0 g 0 G -/F27 9.9626 Tf -24.907 -21.446 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -19.737 Td [(b,a)]TJ -0 g 0 G -/F8 9.9626 Tf 20.098 0 Td [(A)-333(cop)27(y)-333(of)]TJ/F30 9.9626 Tf 45.386 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(with)-333(a)-334(new)-333(storage)-333(format.)]TJ -49.128 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -185.305 -19.737 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ -23.758 -21.446 Td [(The)]TJ/F30 9.9626 Tf 20.085 0 Td [(mold)]TJ/F8 9.9626 Tf 23.848 0 Td [(argumen)28(ts)-294(ma)28(y)-294(b)-28(e)-294(emplo)28(y)28(ed)-294(to)-294(in)28(terface)-294(with)-293(sp)-28(ecial)-294(devices,)-302(suc)28(h)-294(as)]TJ -43.933 -11.955 Td [(GPUs)-333(and)-334(other)-333(accelerators.)]TJ/F27 9.9626 Tf 0 -25.815 Td [(csclip)-383(|)-384(Reduce)-383(to)-383(a)-384(submatrix)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 20.922 -18.389 Td [(call)-525(a%csclip\050b,info[,&)]TJ 15.691 -11.955 Td [(&)-525(imin,imax,jmin,jmax,rscale,cscale]\051)]TJ/F8 9.9626 Tf -21.669 -21.447 Td [(Returns)-222(the)-222(submatrix)]TJ/F30 9.9626 Tf 99.101 0 Td [(A\050imin:imax,jmin:jmax\051)]TJ/F8 9.9626 Tf 115.068 0 Td [(,)-244(optionally)-222(res)-1(calin)1(g)-223(ro)28(w/-)]TJ -229.113 -11.955 Td [(col)-333(indices)-334(to)-333(the)-333(range)]TJ/F30 9.9626 Tf 104.691 0 Td [(1:imax-imin+1,1:jmax-jmin+1)]TJ/F8 9.9626 Tf 141.219 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -245.91 -19.548 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.737 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -19.736 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.359 -31.691 Td [(imin,imax,jmin,jma)-1(x)]TJ -0 g 0 G -/F8 9.9626 Tf 108.413 0 Td [(Minim)28(um)-333(and)-334(maxim)28(um)-333(ro)27(w)-333(and)-333(column)-333(indices.)]TJ -83.506 -11.956 Td [(T)28(yp)-28(e:)-444(optional.)]TJ -0 g 0 G -/F27 9.9626 Tf -24.907 -19.736 Td [(rscale,cscale)]TJ -0 g 0 G -/F8 9.9626 Tf 65.203 0 Td [(Whether)-333(to)-334(rescale)-333(ro)28(w/column)-334(ind)1(ic)-1(es.)-444(T)28(yp)-28(e:)-444(optional.)]TJ -0 g 0 G -/F27 9.9626 Tf -65.203 -21.446 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G -/F8 9.9626 Tf 166.875 -29.888 Td [(19)]TJ -0 g 0 G -ET - -endstream -endobj -925 0 obj -<< -/Length 3769 ->> -stream -0 g 0 G -0 g 0 G -0 g 0 G -BT -/F27 9.9626 Tf 150.705 706.129 Td [(b)]TJ -0 g 0 G -/F8 9.9626 Tf 11.346 0 Td [(A)-333(cop)27(y)-333(of)-333(a)-334(sub)1(m)-1(atr)1(ix)-334(of)]TJ/F30 9.9626 Tf 112.44 0 Td [(a)]TJ/F8 9.9626 Tf 5.23 0 Td [(.)]TJ -104.11 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -185.304 -23.071 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -30.069 Td [(clean)]TJ -ET -q -1 0 0 1 176.852 641.234 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 180.289 641.034 Td [(zeros)-383(|)-384(Eliminate)-383(zero)-383(c)-1(o)-31(e\016ci)-1(e)1(n)31(ts)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf -8.663 -19.852 Td [(call)-525(a%clean_zeros\050info\051)]TJ/F8 9.9626 Tf -5.977 -25.064 Td [(Eliminates)-285(zero)-284(co)-28(e\016cien)27(ts)-284(in)-285(the)-285(i)1(nput)-285(matrix.)-428(Note)-285(that)-285(dep)-27(ending)-285(on)-284(the)]TJ -14.944 -11.955 Td [(in)28(ternal)-333(storage)-333(format,)-333(there)-334(ma)28(y)-333(still)-333(b)-28(e)-333(some)-333(amoun)28(t)-333(of)-334(zero)-333(padding)-333(in)-333(the)]TJ 0 -11.955 Td [(output.)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -25.064 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -23.071 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -23.071 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.355 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.358 -36.232 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -23.071 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.55 0 Td [(The)-333(matrix)]TJ/F30 9.9626 Tf 52.886 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(without)-333(zero)-334(co)-27(e\016)-1(cien)28(ts.)]TJ -47.081 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -185.304 -23.071 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -30.069 Td [(get)]TJ -ET -q -1 0 0 1 166.827 352.894 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 170.264 352.695 Td [(diag)-383(|)-384(Get)-383(main)-383(di)-1(agonal)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 1.362 -19.853 Td [(call)-525(a%get_diag\050d,info\051)]TJ/F8 9.9626 Tf -5.977 -25.064 Td [(Returns)-333(a)-334(cop)28(y)-333(of)-333(the)-334(main)-333(diagonal.)]TJ -0 g 0 G -/F27 9.9626 Tf -14.944 -22.284 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -23.071 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -23.071 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.355 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.358 -37.018 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -23.071 Td [(d)]TJ -0 g 0 G -/F8 9.9626 Tf 11.346 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-334(main)-333(diagonal.)]TJ 13.56 -11.955 Td [(A)-333(one-dimensional)-334(arra)28(y)-333(of)-333(the)-334(appropriate)-333(t)28(yp)-28(e.)]TJ -0 g 0 G -/F27 9.9626 Tf -24.906 -23.071 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ -0 g 0 G - 143.116 -29.888 Td [(20)]TJ -0 g 0 G -ET - -endstream -endobj -929 0 obj -<< -/Length 4823 ->> -stream -0 g 0 G -0 g 0 G -BT -/F27 9.9626 Tf 99.895 706.129 Td [(clip)]TJ -ET -q -1 0 0 1 118.405 706.328 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.842 706.129 Td [(diag)-383(|)-384(Cut)-383(out)-383(main)-384(diagonal)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf -1.025 -18.389 Td [(call)-525(a%clip_diag\050b,info\051)]TJ/F8 9.9626 Tf -5.978 -20.89 Td [(Returns)-333(a)-334(cop)28(y)-333(of)]TJ/F30 9.9626 Tf 80.753 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(without)-333(the)-334(main)-333(diagonal.)]TJ -0 g 0 G -/F27 9.9626 Tf -104.248 -19.103 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.514 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -19.514 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.359 -32.845 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -19.514 Td [(b)]TJ -0 g 0 G -/F8 9.9626 Tf 11.347 0 Td [(A)-333(cop)27(y)-333(of)]TJ/F30 9.9626 Tf 45.385 0 Td [(a)]TJ/F8 9.9626 Tf 8.551 0 Td [(without)-333(the)-334(main)-333(diagonal.)]TJ -40.376 -11.956 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -185.305 -19.514 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -25.719 Td [(tril)-383(|)-384(Return)-383(the)-383(lo)31(w)32(er)-383(triangle)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 20.922 -18.389 Td [(call)-525(a%tril\050l,info[,&)]TJ 15.691 -11.955 Td [(&)-525(diag,imin,imax,jmin,jmax,rscale,cscale,u]\051)]TJ/F8 9.9626 Tf -21.669 -20.89 Td [(Returns)-376(the)-376(lo)28(w)28(er)-376(triangular)-376(p)1(art)-376(of)-376(submatrix)]TJ/F30 9.9626 Tf 210.933 0 Td [(A\050imin:imax,jmin:jmax\051)]TJ/F8 9.9626 Tf 115.067 0 Td [(,)]TJ -340.944 -11.955 Td [(optionally)-222(rescaling)-222(ro)27(w/col)-222(indices)-222(to)-222(the)-222(range)]TJ/F30 9.9626 Tf 205.536 0 Td [(1:imax-imin+1,1:jmax-jmin+1)]TJ/F8 9.9626 Tf -205.536 -11.955 Td [(and)-333(returing)-334(th)1(e)-334(complemen)28(tary)-333(upp)-28(er)-333(triangle.)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -19.103 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.514 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -19.514 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.359 -31.47 Td [(diag)]TJ -0 g 0 G -/F8 9.9626 Tf 25.827 0 Td [(Include)-392(diagonals)-391(up)-392(to)-392(this)-391(one;)]TJ/F30 9.9626 Tf 149.735 0 Td [(diag=1)]TJ/F8 9.9626 Tf 35.284 0 Td [(means)-392(the)-392(\014rst)-391(sup)-28(erdiagonal,)]TJ/F30 9.9626 Tf -185.939 -11.955 Td [(diag=-1)]TJ/F8 9.9626 Tf 39.933 0 Td [(means)-333(the)-334(\014rst)-333(sub)-28(diagonal.)-444(Default)-333(0.)]TJ -0 g 0 G -/F27 9.9626 Tf -64.84 -19.514 Td [(imin,imax,jmin,jmax)]TJ -0 g 0 G -/F8 9.9626 Tf 108.413 0 Td [(Minim)28(um)-333(and)-334(maxim)28(um)-333(ro)28(w)-334(and)-333(column)-333(indices.)]TJ -83.506 -11.955 Td [(T)28(yp)-28(e:)-444(optional.)]TJ -0 g 0 G -/F27 9.9626 Tf -24.907 -19.514 Td [(rscale,cscale)]TJ -0 g 0 G -/F8 9.9626 Tf 65.203 0 Td [(Whether)-333(to)-334(rescale)-333(ro)28(w/column)-334(ind)1(ic)-1(es.)-444(T)28(yp)-28(e:)-444(optional.)]TJ -0 g 0 G -/F27 9.9626 Tf -65.203 -20.89 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -19.514 Td [(l)]TJ -0 g 0 G -/F8 9.9626 Tf 8.164 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-334(lo)28(w)28(er)-333(triangle)-334(of)]TJ/F30 9.9626 Tf 136.489 0 Td [(a)]TJ/F8 9.9626 Tf 5.23 0 Td [(.)]TJ -124.976 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -185.305 -19.514 Td [(u)]TJ -0 g 0 G -/F8 9.9626 Tf 11.347 0 Td [(\050optional\051)-333(A)-334(cop)28(y)-333(of)-333(the)-334(upp)-27(er)-334(triangle)-333(of)]TJ/F30 9.9626 Tf 185.471 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ -177.142 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -185.305 -19.514 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ -0 g 0 G - 143.117 -29.888 Td [(21)]TJ -0 g 0 G -ET - -endstream -endobj -933 0 obj -<< -/Length 4738 ->> -stream -0 g 0 G -0 g 0 G -BT -/F27 9.9626 Tf 150.705 706.129 Td [(triu)-383(|)-384(Return)-383(the)-383(upp)-32(er)-384(triangle)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 20.921 -18.597 Td [(call)-525(a%triu\050u,info[,&)]TJ 15.691 -11.955 Td [(&)-525(diag,imin,imax,jmin,jmax,rscale,cscale,l]\051)]TJ/F8 9.9626 Tf -21.668 -22.364 Td [(Returns)-340(the)-340(upp)-28(er)-340(triangular)-340(part)-340(of)-340(submatrix)]TJ/F30 9.9626 Tf 210.932 0 Td [(A\050imin:imax,jmin:jmax\051)]TJ/F8 9.9626 Tf 115.068 0 Td [(,)]TJ -340.944 -11.955 Td [(optionally)-222(rescaling)-222(ro)28(w)-1(/col)-222(indices)-222(to)-222(the)-222(range)]TJ/F30 9.9626 Tf 205.535 0 Td [(1:imax-imin+1,1:jmax-jmin+1)]TJ/F8 9.9626 Tf 141.219 0 Td [(,)]TJ -346.754 -11.955 Td [(and)-333(returing)-333(the)-334(complemen)28(tary)-333(lo)27(w)28(er)-333(triangle.)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -20.26 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -20.371 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -20.372 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.355 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -160.398 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.358 -32.326 Td [(diag)]TJ -0 g 0 G -/F8 9.9626 Tf 25.826 0 Td [(Include)-392(diagonals)-391(up)-392(to)-392(this)-392(on)1(e)-1(;)]TJ/F30 9.9626 Tf 149.735 0 Td [(diag=1)]TJ/F8 9.9626 Tf 35.285 0 Td [(means)-392(the)-392(\014)1(rs)-1(t)-391(sup)-28(erdiagonal,)]TJ/F30 9.9626 Tf -185.94 -11.955 Td [(diag=-1)]TJ/F8 9.9626 Tf 39.934 0 Td [(means)-333(the)-334(\014rst)-333(sub)-28(diagonal.)-444(Default)-333(0.)]TJ -0 g 0 G -/F27 9.9626 Tf -64.84 -20.372 Td [(imin,imax,jmin,jmax)]TJ -0 g 0 G -/F8 9.9626 Tf 108.412 0 Td [(Minim)28(um)-333(a)-1(n)1(d)-334(maxim)28(um)-333(ro)27(w)-333(and)-333(column)-333(indices.)]TJ -83.506 -11.955 Td [(T)28(yp)-28(e:)-444(optional.)]TJ -0 g 0 G -/F27 9.9626 Tf -24.906 -20.371 Td [(rscale,cscale)]TJ -0 g 0 G -/F8 9.9626 Tf 65.202 0 Td [(Whether)-333(to)-334(rescale)-333(ro)28(w/column)-334(indices.)-444(T)28(yp)-28(e:)-445(op)1(tional.)]TJ -0 g 0 G -/F27 9.9626 Tf -65.202 -22.364 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -20.371 Td [(u)]TJ -0 g 0 G -/F8 9.9626 Tf 11.346 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-334(u)1(pp)-28(er)-334(tr)1(iangle)-334(of)]TJ/F30 9.9626 Tf 138.979 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ -130.65 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -185.304 -20.372 Td [(l)]TJ -0 g 0 G -/F8 9.9626 Tf 8.164 0 Td [(\050optional\051)-333(A)-334(cop)28(y)-333(of)-333(the)-334(lo)28(w)28(er)-333(triangle)-334(of)]TJ/F30 9.9626 Tf 182.98 0 Td [(a)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ -171.469 -11.955 Td [(A)-333(v)55(ariable)-333(of)-333(t)27(yp)-27(e)]TJ/F30 9.9626 Tf 81.943 0 Td [(psb_Tspmat_type)]TJ/F8 9.9626 Tf 78.455 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -185.304 -20.371 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -26.488 Td [(psb)]TJ -ET -q -1 0 0 1 168.641 313.735 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 172.078 313.535 Td [(set)]TJ -ET -q -1 0 0 1 186.992 313.735 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 190.429 313.535 Td [(mat)]TJ -ET -q -1 0 0 1 210.688 313.735 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 214.125 313.535 Td [(default)-383(|)-384(Set)-383(default)-383(storage)-384(format)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf -63.42 -18.596 Td [(call)-1050(psb_set_mat_default\050a\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -22.253 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -20.371 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -20.371 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(a)-285(v)56(ariable)-285(of)]TJ/F30 9.9626 Tf 55.581 0 Td [(class\050psb_T_base_sparse_mat\051)]TJ/F8 9.9626 Tf 149.285 0 Td [(requesting)-285(a)-284(new)-285(default)-285(stor-)]TJ -190.511 -11.955 Td [(age)-333(format.)]TJ 0 -11.956 Td [(T)28(yp)-28(e:)-444(required.)]TJ/F27 9.9626 Tf -24.906 -26.487 Td [(clone)-383(|)-384(Clone)-383(curren)32(t)-383(ob)-64(ject)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 0 -18.597 Td [(call)-1050(a%clone\050b,info\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -22.252 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -20.371 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G -/F8 9.9626 Tf 166.874 -29.888 Td [(22)]TJ -0 g 0 G -ET - -endstream -endobj -939 0 obj -<< -/Length 7666 ->> -stream -0 g 0 G -0 g 0 G -0 g 0 G -BT -/F27 9.9626 Tf 99.895 706.129 Td [(a)]TJ -0 g 0 G -/F8 9.9626 Tf 10.551 0 Td [(the)-333(sparse)-334(matrix.)]TJ 14.356 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -80.359 -35.408 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -21.972 Td [(b)]TJ -0 g 0 G -/F8 9.9626 Tf 11.347 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-333(input)-334(ob)-55(ject.)]TJ -0 g 0 G -/F27 9.9626 Tf -11.347 -21.973 Td [(info)]TJ -0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F27 9.9626 Tf -23.758 -28.61 Td [(3.2.2)-1150(Named)-383(Constan)31(ts)]TJ -0 g 0 G - 0 -19.342 Td [(psb)]TJ -ET -q -1 0 0 1 117.832 567.068 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.269 566.869 Td [(dupl)]TJ -ET -q -1 0 0 1 144.234 567.068 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 147.671 566.869 Td [(o)32(vwrt)]TJ -ET -q -1 0 0 1 177.264 567.068 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -0 g 0 G -BT -/F8 9.9626 Tf 185.682 566.869 Td [(Duplicate)-315(co)-28(e\016cien)28(ts)-315(should)-315(b)-28(e)-315(o)28(v)28(erwritten)-315(\050i.e.)-438(ignore)-315(du-)]TJ -60.88 -11.955 Td [(plications\051)]TJ -0 g 0 G -/F27 9.9626 Tf -24.907 -21.972 Td [(psb)]TJ -ET -q -1 0 0 1 117.832 533.141 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.269 532.942 Td [(dupl)]TJ -ET -q -1 0 0 1 144.234 533.141 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 147.671 532.942 Td [(add)]TJ -ET -q -1 0 0 1 166.658 533.141 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -0 g 0 G -BT -/F8 9.9626 Tf 175.076 532.942 Td [(Duplicate)-333(co)-28(e\016cien)28(ts)-334(should)-333(b)-28(e)-333(added;)]TJ -0 g 0 G -/F27 9.9626 Tf -75.181 -21.972 Td [(psb)]TJ -ET -q -1 0 0 1 117.832 511.169 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.269 510.97 Td [(dupl)]TJ -ET -q -1 0 0 1 144.234 511.169 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 147.671 510.97 Td [(err)]TJ -ET -q -1 0 0 1 163.046 511.169 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -0 g 0 G -BT -/F8 9.9626 Tf 171.465 510.97 Td [(Duplicate)-333(co)-28(e\016cien)28(ts)-334(should)-333(trigger)-333(an)-334(error)-333(conditino)]TJ -0 g 0 G -/F27 9.9626 Tf -71.57 -21.972 Td [(psb)]TJ -ET -q -1 0 0 1 117.832 489.197 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.269 488.998 Td [(up)-32(d)]TJ -ET -q -1 0 0 1 141.37 489.197 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 144.807 488.998 Td [(d\015t)]TJ -ET -q -1 0 0 1 162.68 489.197 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -0 g 0 G -BT -/F8 9.9626 Tf 171.098 488.998 Td [(Default)-333(up)-28(date)-333(strategy)-334(for)-333(matrix)-333(co)-28(e\016cien)28(ts;)]TJ -0 g 0 G -/F27 9.9626 Tf -71.203 -21.972 Td [(psb)]TJ -ET -q -1 0 0 1 117.832 467.225 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.269 467.026 Td [(up)-32(d)]TJ -ET -q -1 0 0 1 141.37 467.225 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 144.807 467.026 Td [(src)32(h)]TJ -ET -q -1 0 0 1 165.87 467.225 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -0 g 0 G -BT -/F8 9.9626 Tf 174.289 467.026 Td [(Up)-28(date)-333(strategy)-333(based)-334(on)-333(searc)28(h)-334(in)28(to)-333(the)-334(d)1(ata)-334(structure;)]TJ -0 g 0 G -/F27 9.9626 Tf -74.394 -21.973 Td [(psb)]TJ -ET -q -1 0 0 1 117.832 445.253 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 121.269 445.053 Td [(up)-32(d)]TJ -ET -q -1 0 0 1 141.37 445.253 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 144.807 445.053 Td [(p)-32(erm)]TJ -ET -q -1 0 0 1 171.694 445.253 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -0 g 0 G -BT -/F8 9.9626 Tf 180.113 445.053 Td [(Up)-28(date)-398(strategy)-398(based)-398(on)-398(additional)-398(p)-28(erm)28(utation)-398(data)-398(\050se)-1(e)]TJ -55.311 -11.955 Td [(to)-28(ols)-333(routine)-333(description\051.)]TJ/F16 11.9552 Tf -24.907 -30.603 Td [(3.3)-1125(Dense)-375(V)94(ector)-375(Data)-375(Structure)]TJ/F8 9.9626 Tf 0 -19.342 Td [(The)]TJ/F30 9.9626 Tf 21.256 0 Td [(psb)]TJ -ET -q -1 0 0 1 137.47 383.353 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 140.608 383.153 Td [(T)]TJ -ET -q -1 0 0 1 146.466 383.353 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 149.604 383.153 Td [(vect)]TJ -ET -q -1 0 0 1 171.153 383.353 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 174.291 383.153 Td [(type)]TJ/F8 9.9626 Tf 25.02 0 Td [(data)-411(structure)-412(encapsulates)-411(the)-411(dense)-412(v)28(ectors)-411(in)-412(a)-411(w)28(a)28(y)]TJ -99.416 -11.955 Td [(similar)-434(to)-435(sparse)-434(matrices,)-459(i.e.)-748(includ)1(ing)-435(a)-434(base)-434(t)28(yp)-28(e)]TJ/F30 9.9626 Tf 242.195 0 Td [(psb)]TJ -ET -q -1 0 0 1 358.409 371.397 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 361.547 371.198 Td [(T)]TJ -ET -q -1 0 0 1 367.405 371.397 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 370.543 371.198 Td [(base)]TJ -ET -q -1 0 0 1 392.092 371.397 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 395.231 371.198 Td [(vect)]TJ -ET -q -1 0 0 1 416.779 371.397 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 419.918 371.198 Td [(type)]TJ/F8 9.9626 Tf 20.921 0 Td [(.)]TJ -340.944 -11.955 Td [(The)-330(user)-330(will)-330(not,)-330(in)-330(general,)-331(access)-330(the)-330(v)28(ector)-330(comp)-28(onen)28(ts)-330(directly)83(,)-330(but)-330(rather)]TJ 0 -11.955 Td [(via)-303(the)-304(routi)1(ne)-1(s)-303(of)-303(sec.)]TJ -0 0 1 rg 0 0 1 RG - [-304(6)]TJ -0 g 0 G - [(.)-434(Among)-303(other)-303(s)-1(impl)1(e)-304(things,)-309(w)28(e)-304(de\014ne)-303(here)-303(an)-303(e)-1(xtr)1(ac)-1(-)]TJ 0 -11.955 Td [(tion)-321(metho)-28(d)-320(that)-321(can)-321(b)-27(e)-321(used)-321(to)-321(get)-321(a)-320(full)-321(cop)28(y)-321(of)-321(the)-320(part)-321(of)-321(the)-320(v)27(ector)-320(s)-1(t)1(o)-1(r)1(e)-1(d)]TJ 0 -11.956 Td [(on)-333(the)-334(lo)-27(cal)-334(pro)-27(c)-1(ess.)]TJ 14.944 -12.466 Td [(The)-399(t)28(yp)-28(e)-399(declaration)-398(is)-399(sho)28(w)-1(n)-398(in)-399(\014gure)]TJ -0 0 1 rg 0 0 1 RG - [-399(5)]TJ -0 g 0 G - [-399(where)]TJ/F30 9.9626 Tf 216.941 0 Td [(T)]TJ/F8 9.9626 Tf 9.203 0 Td [(is)-399(a)-399(placeholder)-398(for)-399(the)]TJ -241.088 -11.956 Td [(data)-333(t)27(yp)-27(e)-334(and)-333(precision)-333(v)55(arian)28(ts)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -21.46 Td [(I)]TJ -0 g 0 G -/F8 9.9626 Tf 9.326 0 Td [(In)28(teger;)]TJ -0 g 0 G -/F27 9.9626 Tf -9.326 -21.972 Td [(S)]TJ -0 g 0 G -/F8 9.9626 Tf 11.347 0 Td [(Single)-333(precision)-334(real;)]TJ -0 g 0 G -/F27 9.9626 Tf -11.347 -21.972 Td [(D)]TJ -0 g 0 G -/F8 9.9626 Tf 13.768 0 Td [(Double)-333(precision)-334(real;)]TJ -0 g 0 G -/F27 9.9626 Tf -13.768 -21.972 Td [(C)]TJ -0 g 0 G -/F8 9.9626 Tf 13.256 0 Td [(Single)-333(precision)-334(complex;)]TJ -0 g 0 G -/F27 9.9626 Tf -13.256 -21.972 Td [(Z)]TJ -0 g 0 G -/F8 9.9626 Tf 11.983 0 Td [(Double)-333(precision)-334(complex.)]TJ -11.983 -21.461 Td [(The)-281(actual)-280(data)-280(is)-281(con)28(tained)-281(i)1(n)-281(the)-280(p)-28(olymorphic)-281(comp)-27(onen)27(t)]TJ/F30 9.9626 Tf 260.737 0 Td [(v%v)]TJ/F8 9.9626 Tf 15.691 0 Td [(;)-298(the)-281(separation)]TJ -276.428 -11.955 Td [(b)-28(et)28(w)28(een)-427(the)-426(application)-427(and)-426(the)-427(actual)-426(data)-426(is)-427(essen)28(tial)-427(for)-426(cases)-427(where)-426(it)-427(is)]TJ 0 -11.955 Td [(necessary)-426(to)-426(link)-425(to)-426(data)-426(storage)-426(made)-425(a)27(v)56(ailable)-426(elsewhere)-426(outside)-425(the)-426(direct)]TJ 0 -11.955 Td [(con)28(trol)-335(of)-335(the)-336(compiler/appli)1(c)-1(ation)1(,)-336(e.g.)-450(data)-335(stored)-335(in)-335(a)-335(graphics)-336(accelerator's)]TJ 0 -11.955 Td [(priv)56(ate)-334(memory)84(.)]TJ -0 g 0 G - 166.874 -29.888 Td [(23)]TJ -0 g 0 G -ET - -endstream -endobj -945 0 obj -<< -/Length 3183 ->> -stream -0 g 0 G -0 g 0 G -0 g 0 G -0 g 0 G -0 g 0 G -0 g 0 G -0 g 0 G -BT -/F30 9.9626 Tf 186.943 710.003 Td [(type)-525(psb_T_base_vect_type)]TJ 10.46 -11.955 Td [(TYPE\050KIND_\051,)-525(allocatable)-525(::)-525(v\050:\051)]TJ -10.46 -11.955 Td [(end)-525(type)-525(psb_T_base_vect_type)]TJ 0 -23.91 Td [(type)-525(psb_T_vect_type)]TJ 10.46 -11.956 Td [(class\050psb_T_base_vect_type\051,)-525(allocatable)-525(::)-525(v)]TJ -10.46 -11.955 Td [(end)-525(type)-1050(psb_T_vect_type)]TJ -0 g 0 G -/F8 9.9626 Tf -22.069 -39.795 Td [(Figure)-333(5:)-889(The)-333(PSBLAS)-334(de\014ned)-333(data)-333(t)27(y)1(p)-28(e)-334(that)-333(con)28(tains)-333(a)-334(dense)-333(v)28(ector.)]TJ -0 g 0 G -0 g 0 G -/F27 9.9626 Tf -14.169 -31.831 Td [(3.3.1)-1150(V)96(ector)-384(Metho)-32(ds)]TJ 0 -18.394 Td [(get)]TJ -ET -q -1 0 0 1 166.827 548.451 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 170.264 548.252 Td [(nro)32(ws)-383(|)-384(Get)-383(n)32(um)32(b)-32(er)-383(of)-384(ro)32(ws)-383(in)-383(a)-384(dense)-383(v)32(ector)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf -19.559 -18.395 Td [(nr)-525(=)-525(v%get_nrows\050\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -21.926 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.937 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -19.937 Td [(v)]TJ + 0 -21.66 Td [(v)]TJ 0 g 0 G /F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector)]TJ 13.878 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ 0 g 0 G - -57.285 -33.882 Td [(On)-383(Return)]TJ + -57.285 -33.615 Td [(n)]TJ +0 g 0 G +/F8 9.9626 Tf 11.346 0 Td [(Size)-333(to)-334(b)-27(e)-334(returned)]TJ 13.56 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -55.452 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(optional)]TJ/F8 9.9626 Tf 40.576 0 Td [(;)-333(default:)-445(en)28(tire)-333(v)28(ec)-1(tor)1(.)]TJ +0 g 0 G +/F27 9.9626 Tf -95.094 -35.174 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -19.936 Td [(F)96(unction)-384(v)64(alue)]TJ + 0 -21.66 Td [(F)96(unction)-384(v)64(alue)]TJ 0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(The)-333(n)27(um)28(b)-28(er)-333(of)-333(ro)28(ws)-334(of)-333(dense)-333(v)27(ector)]TJ/F30 9.9626 Tf 159.596 0 Td [(v)]TJ/F8 9.9626 Tf 5.231 0 Td [(.)]TJ/F27 9.9626 Tf -243.213 -25.911 Td [(sizeof)-383(|)-384(Get)-383(memory)-383(o)-32(ccupation)-384(in)-383(b)32(ytes)-384(of)-383(a)-383(dense)-384(v)32(ector)]TJ +/F8 9.9626 Tf 78.386 0 Td [(An)-353(allo)-28(catable)-354(arra)28(y)-353(holding)-354(a)-353(cop)28(y)-354(of)-353(the)-354(dense)-353(v)28(ec)-1(t)1(o)-1(r)-353(con-)]TJ -53.48 -11.956 Td [(ten)28(ts.)-440(If)-319(the)-320(argumen)28(t)]TJ/F11 9.9626 Tf 99.799 0 Td [(n)]TJ/F8 9.9626 Tf 9.161 0 Td [(is)-319(sp)-28(eci\014ed,)-322(the)-320(size)-319(of)-319(the)-320(returned)-319(arra)28(y)-320(equals)]TJ -108.96 -11.955 Td [(the)-401(minim)28(um)-401(b)-28(et)28(w)28(een)]TJ/F11 9.9626 Tf 102.199 0 Td [(n)]TJ/F8 9.9626 Tf 9.974 0 Td [(and)-401(the)-401(in)28(ternal)-401(size)-401(of)-400(the)-401(v)27(ector,)-417(or)-401(0)-401(if)]TJ/F11 9.9626 Tf 189.961 0 Td [(n)]TJ/F8 9.9626 Tf 9.974 0 Td [(is)]TJ -312.108 -11.955 Td [(negativ)28(e;)-389(otherwise,)-380(the)-371(size)-370(of)-371(the)-370(arra)28(y)-371(is)-370(the)-371(same)-371(as)-370(the)-371(in)28(ternal)-370(size)]TJ 0 -11.955 Td [(of)-333(the)-334(v)28(ector.)]TJ/F27 9.9626 Tf -24.906 -28.197 Td [(clone)-383(|)-384(Clone)-383(curren)32(t)-383(ob)-64(ject)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf 0 -18.395 Td [(memory_size)-525(=)-525(v%sizeof\050\051)]TJ +/F30 9.9626 Tf 0 -19.197 Td [(call)-1050(x%clone\050y,info\051)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -21.926 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -23.218 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -19.937 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -21.66 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -19.937 Td [(v)]TJ -0 g 0 G -/F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector)]TJ 13.879 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.378 0 Td [(lo)-32(cal)]TJ -0 g 0 G - -57.285 -33.882 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -19.936 Td [(F)96(unction)-384(v)64(alue)]TJ -0 g 0 G -/F8 9.9626 Tf 78.386 0 Td [(The)-333(memory)-334(o)-28(ccupation)-333(in)-333(b)28(ytes.)]TJ/F27 9.9626 Tf -78.386 -25.911 Td [(set)-383(|)-384(Set)-383(con)32(ten)32(ts)-383(of)-384(the)-383(v)32(ector)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 5.23 -18.395 Td [(call)-1050(v%set\050alpha[,first,last]\051)]TJ 0 -11.955 Td [(call)-1050(v%set\050vect[,first,last]\051)]TJ 0 -11.955 Td [(call)-1050(v%zero\050\051)]TJ -0 g 0 G -/F27 9.9626 Tf -5.23 -21.927 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -19.936 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G -/F8 9.9626 Tf 166.874 -29.888 Td [(24)]TJ -0 g 0 G -ET - -endstream -endobj -951 0 obj -<< -/Length 5078 ->> -stream -0 g 0 G -0 g 0 G -0 g 0 G -BT -/F27 9.9626 Tf 99.895 706.129 Td [(v)]TJ -0 g 0 G -/F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector)]TJ 13.879 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ -0 g 0 G - -57.286 -30.343 Td [(alpha)]TJ -0 g 0 G -/F8 9.9626 Tf 32.033 0 Td [(A)-333(scalar)-334(v)56(alue.)]TJ -7.126 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf -29.611 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.956 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(n)28(um)28(b)-28(er)-333(of)-334(the)-333(data)-333(t)28(yp)-28(e)-334(ind)1(ic)-1(ated)-333(in)-333(T)83(able)]TJ -0 0 1 rg 0 0 1 RG - [-333(1)]TJ -0 g 0 G - [(.)]TJ -0 g 0 G -/F27 9.9626 Tf -24.907 -18.387 Td [(\014rst,last)]TJ -0 g 0 G -/F8 9.9626 Tf 45.949 0 Td [(Boundaries)-333(for)-334(setting)-333(in)-333(the)-333(v)27(ector.)]TJ -21.042 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(optional)]TJ/F8 9.9626 Tf -29.611 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.956 Td [(Sp)-28(eci\014ed)-333(as:)-445(in)28(tegers.)]TJ -0 g 0 G -/F27 9.9626 Tf -24.907 -18.387 Td [(v)32(ect)]TJ -0 g 0 G -/F8 9.9626 Tf 25.509 0 Td [(An)-333(arra)28(y)]TJ -0.602 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf -29.611 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.956 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(n)28(um)28(b)-28(er)-333(of)-334(the)-333(data)-333(t)28(yp)-28(e)-334(ind)1(ic)-1(ated)-333(in)-333(T)83(able)]TJ -0 0 1 rg 0 0 1 RG - [-333(1)]TJ -0 g 0 G - [(.)]TJ -24.907 -18.073 Td [(Note)-392(t)1(hat)-392(a)-391(call)-392(to)]TJ/F30 9.9626 Tf 87.3 0 Td [(v%zero\050\051)]TJ/F8 9.9626 Tf 45.742 0 Td [(is)-391(pro)27(vided)-391(as)-391(a)-392(shorthand,)-406(but)-391(is)-391(equiv)55(alen)28(t)-391(to)]TJ -133.042 -11.955 Td [(a)-320(call)-319(to)]TJ/F30 9.9626 Tf 38.336 0 Td [(v%set\050zero\051)]TJ/F8 9.9626 Tf 60.718 0 Td [(with)-320(the)]TJ/F30 9.9626 Tf 39.579 0 Td [(zero)]TJ/F8 9.9626 Tf 24.106 0 Td [(constan)28(t)-320(ha)28(ving)-320(the)-319(appropriate)-320(t)28(yp)-28(e)-320(and)]TJ -162.739 -11.955 Td [(kind.)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -18.073 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -18.387 Td [(v)]TJ -0 g 0 G -/F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector,)-333(with)-334(up)-27(dated)-334(en)28(tries)]TJ 13.879 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ -57.286 -37.189 Td [(get)]TJ -ET -q -1 0 0 1 116.018 356.206 cm -[]0 d 0 J 0.398 w 0 0 m 3.437 0 l S -Q -BT -/F27 9.9626 Tf 119.455 356.007 Td [(v)32(ect)-383(|)-384(Get)-383(a)-383(cop)32(y)-384(of)-383(the)-383(v)31(ector)-383(con)32(ten)32(ts)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf -19.56 -18.39 Td [(extv)-525(=)-525(v%get_vect\050[n]\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -18.073 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -18.387 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -18.387 Td [(v)]TJ -0 g 0 G -/F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector)]TJ 13.879 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ -0 g 0 G - -57.286 -30.343 Td [(n)]TJ -0 g 0 G -/F8 9.9626 Tf 11.347 0 Td [(Size)-333(to)-334(b)-27(e)-334(returned)]TJ 13.56 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -55.452 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(optional)]TJ/F8 9.9626 Tf 40.577 0 Td [(;)-333(default:)-445(en)28(tire)-333(v)28(ector.)]TJ -0 g 0 G -/F27 9.9626 Tf -95.095 -30.028 Td [(On)-383(Return)]TJ -0 g 0 G -0 g 0 G - 0 -18.388 Td [(F)96(unction)-384(v)64(alue)]TJ -0 g 0 G -/F8 9.9626 Tf 78.387 0 Td [(An)-353(allo)-28(catable)-354(arra)28(y)-353(holding)-354(a)-353(cop)28(y)-354(of)-353(the)-354(dense)-353(v)28(ector)-354(con-)]TJ -53.48 -11.955 Td [(ten)28(ts.)-440(If)-319(the)-320(argumen)28(t)]TJ/F11 9.9626 Tf 99.799 0 Td [(n)]TJ/F8 9.9626 Tf 9.161 0 Td [(is)-319(sp)-28(eci\014ed,)-322(the)-320(size)-319(of)-319(the)-320(returned)-319(arra)28(y)-319(e)-1(qu)1(als)]TJ -108.96 -11.955 Td [(the)-401(minim)28(um)-401(b)-28(et)28(w)28(een)]TJ/F11 9.9626 Tf 102.199 0 Td [(n)]TJ/F8 9.9626 Tf 9.974 0 Td [(and)-401(the)-401(in)28(ternal)-401(size)-401(of)-400(the)-401(v)27(ector,)-417(or)-401(0)-401(if)]TJ/F11 9.9626 Tf 189.961 0 Td [(n)]TJ/F8 9.9626 Tf 9.973 0 Td [(is)]TJ -312.107 -11.955 Td [(negativ)28(e;)-389(otherwise,)-380(the)-371(size)-370(of)-371(the)-370(arra)28(y)-371(is)-370(the)-371(same)-371(as)-370(the)-371(in)28(ternal)-370(size)]TJ 0 -11.955 Td [(of)-333(the)-334(v)28(ector.)]TJ -0 g 0 G - 141.968 -29.888 Td [(25)]TJ -0 g 0 G -ET - -endstream -endobj -959 0 obj -<< -/Length 5381 ->> -stream -0 g 0 G -0 g 0 G -BT -/F27 9.9626 Tf 150.705 706.129 Td [(clone)-383(|)-384(Clone)-383(curren)32(t)-383(ob)-64(ject)]TJ -0 g 0 G -0 g 0 G -/F30 9.9626 Tf 0 -18.469 Td [(call)-1050(x%clone\050y,info\051)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -22.046 Td [(T)32(yp)-32(e:)]TJ -0 g 0 G -/F8 9.9626 Tf 33.797 0 Td [(Async)28(hronous.)]TJ -0 g 0 G -/F27 9.9626 Tf -33.797 -20.096 Td [(On)-383(En)32(try)]TJ -0 g 0 G -0 g 0 G - 0 -20.096 Td [(x)]TJ + 0 -21.661 Td [(x)]TJ 0 g 0 G /F8 9.9626 Tf 11.028 0 Td [(the)-333(dense)-334(v)28(ector.)]TJ 13.878 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -80.358 -34.001 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -80.358 -35.174 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -20.096 Td [(y)]TJ + 0 -21.66 Td [(y)]TJ 0 g 0 G /F8 9.9626 Tf 11.028 0 Td [(A)-333(cop)27(y)-333(of)-333(the)-333(input)-334(ob)-55(ject.)]TJ 0 g 0 G -/F27 9.9626 Tf -11.028 -20.096 Td [(info)]TJ +/F27 9.9626 Tf -11.028 -21.66 Td [(info)]TJ 0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F16 11.9552 Tf -23.758 -28.115 Td [(3.4)-1125(Preconditioner)-375(data)-375(structure)]TJ/F8 9.9626 Tf 0 -18.469 Td [(Our)-383(base)-383(library)-383(o\013ers)-383(supp)-28(ort)-383(for)-383(simple)-383(w)28(ell)-383(kno)27(wn)-383(precondition)1(e)-1(r)1(s)-384(lik)28(e)-383(Di-)]TJ 0 -11.955 Td [(agonal)-333(Scaling)-334(or)-333(Blo)-28(c)28(k)-333(Jacobi)-334(with)-333(incomplete)-333(factorization)-333(ILU)-1(\050)1(0\051.)]TJ 14.944 -11.998 Td [(A)-427(preconditioner)-428(is)-427(held)-428(in)-427(the)]TJ/F30 9.9626 Tf 142.723 0 Td [(psb)]TJ +/F8 9.9626 Tf 23.758 0 Td [(Return)-333(co)-28(de.)]TJ/F16 11.9552 Tf -23.758 -30.189 Td [(3.4)-1125(Preconditioner)-375(data)-375(structure)]TJ/F8 9.9626 Tf 0 -19.197 Td [(Our)-383(base)-383(library)-383(o\013ers)-383(supp)-28(ort)-383(for)-383(simple)-383(w)28(ell)-383(kno)27(wn)-383(precondition)1(e)-1(r)1(s)-384(lik)28(e)-383(Di-)]TJ 0 -11.955 Td [(agonal)-333(Scaling)-334(or)-333(Blo)-28(c)28(k)-333(Jacobi)-334(with)-333(incomplete)-333(factorization)-333(ILU\0500\051.)]TJ 14.944 -12.389 Td [(A)-427(preconditioner)-428(is)-427(held)-428(in)-427(the)]TJ/F30 9.9626 Tf 142.723 0 Td [(psb)]TJ ET q -1 0 0 1 324.691 468.937 cm +1 0 0 1 324.691 168.346 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 327.829 468.737 Td [(prec)]TJ +/F30 9.9626 Tf 327.829 168.146 Td [(prec)]TJ ET q -1 0 0 1 349.378 468.937 cm +1 0 0 1 349.378 168.346 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 352.516 468.737 Td [(type)]TJ/F8 9.9626 Tf 25.18 0 Td [(data)-427(structure)-428(rep)-28(orted)-427(in)]TJ -226.991 -11.955 Td [(\014gure)]TJ +/F30 9.9626 Tf 352.516 168.146 Td [(type)]TJ/F8 9.9626 Tf 25.18 0 Td [(data)-427(structure)-428(rep)-28(orted)-427(in)]TJ -226.991 -11.955 Td [(\014gure)]TJ 0 0 1 rg 0 0 1 RG [-361(6)]TJ 0 g 0 G [(.)-527(The)]TJ/F30 9.9626 Tf 61.729 0 Td [(psb_prec_type)]TJ/F8 9.9626 Tf 71.59 0 Td [(data)-361(t)28(yp)-28(e)-361(ma)28(y)-361(con)28(tain)-361(a)-361(simple)-361(preconditionin)1(g)]TJ -133.319 -11.955 Td [(matrix)-488(with)-487(the)-488(asso)-28(ciated)-488(comm)28(unication)-487(des)-1(crip)1(tor.The)-488(in)28(ternal)-488(precondi-)]TJ 0 -11.955 Td [(tioner)-417(is)-417(allo)-28(cated)-417(app)1(ropriately)-417(with)-417(the)-417(dynamic)-417(t)28(yp)-28(e)-417(corresp)-28(onding)-417(to)-417(th)1(e)]TJ 0 -11.955 Td [(desired)-333(preconditioner.)]TJ 0 g 0 G -0 g 0 G -0 g 0 G -0 g 0 G -0 g 0 G -/F47 8.9664 Tf 26.601 -24.937 Td [(type)-525(psb_Tprec_type)]TJ 9.415 -10.959 Td [(class\050psb_T_base_prec_type\051,)-525(allocatable)-525(::)-525(prec)]TJ -9.415 -10.959 Td [(end)-525(type)-525(psb_Tprec_type)]TJ -0 g 0 G -/F8 9.9626 Tf -14.632 -38.799 Td [(Figure)-333(6:)-445(The)-333(PSBLAS)-333(de\014ned)-334(d)1(a)-1(t)1(a)-334(t)28(yp)-28(e)-333(that)-333(con)27(tains)-333(a)-333(preconditioner.)]TJ -0 g 0 G -0 g 0 G -/F16 11.9552 Tf -11.969 -40.155 Td [(3.5)-1125(Heap)-375(data)-375(structure)]TJ/F8 9.9626 Tf 0 -18.469 Td [(Among)-393(the)-393(to)-28(ols)-393(routines)-393(of)-393(sec.)]TJ -0 0 1 rg 0 0 1 RG - [-393(6)]TJ -0 g 0 G - [(,)-408(w)28(e)-393(ha)28(v)27(e)-393(a)-393(n)28(um)28(b)-28(er)-393(of)-393(sorting)-393(utilities;)-423(the)]TJ 0 -11.955 Td [(heap)-333(sort)-334(is)-333(implemen)28(ted)-334(in)-333(terms)-333(of)-334(heaps)-333(ha)28(ving)-333(the)-334(follo)28(wing)-333(signatures:)]TJ -0 g 0 G -/F30 9.9626 Tf 0 -20.053 Td [(psb)]TJ -ET -q -1 0 0 1 167.023 244.83 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 170.162 244.631 Td [(T)]TJ -ET -q -1 0 0 1 176.02 244.83 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 179.158 244.631 Td [(heap)]TJ -0 g 0 G -/F8 9.9626 Tf 25.903 0 Td [(:)-425(a)-295(heap)-296(con)28(taining)-295(elemen)28(ts)-295(of)-295(t)27(yp)-27(e)-296(T,)-295(where)-295(T)-295(can)-295(b)-28(e)]TJ/F30 9.9626 Tf 242.282 0 Td [(i,s,c,d,z)]TJ/F8 9.9626 Tf -271.731 -11.956 Td [(for)-333(in)28(teger,)-334(real)-333(and)-333(complex)-334(data;)]TJ -0 g 0 G -/F30 9.9626 Tf -24.907 -20.096 Td [(psb)]TJ -ET -q -1 0 0 1 167.023 212.779 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 170.162 212.579 Td [(T)]TJ -ET -q -1 0 0 1 176.02 212.779 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 179.158 212.579 Td [(idx)]TJ -ET -q -1 0 0 1 195.476 212.779 cm -[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S -Q -BT -/F30 9.9626 Tf 198.615 212.579 Td [(heap)]TJ -0 g 0 G -/F8 9.9626 Tf 25.902 0 Td [(:)-408(a)-260(heap)-260(con)28(taining)-260(elemen)28(ts)-260(of)-260(t)28(yp)-28(e)-260(T,)-260(as)-260(ab)-27(o)28(v)27(e,)-274(together)-260(with)]TJ -48.906 -11.955 Td [(an)-333(in)27(t)1(e)-1(ger)-333(index.)]TJ -24.906 -20.053 Td [(Giv)28(en)-334(a)-333(heap)-333(ob)-56(ject,)-333(the)-333(follo)27(win)1(g)-334(metho)-28(ds)-333(are)-333(de\014ned)-334(on)-333(it:)]TJ -0 g 0 G -/F27 9.9626 Tf 0 -20.053 Td [(init)]TJ -0 g 0 G -/F8 9.9626 Tf 22.167 0 Td [(Initialize)-333(memory;)-334(also)-333(c)28(ho)-28(ose)-333(as)-1(cendi)1(ng)-334(or)-333(descending)-333(order;)]TJ -0 g 0 G -/F27 9.9626 Tf -22.167 -20.096 Td [(ho)32(wman)32(y)]TJ -0 g 0 G -/F8 9.9626 Tf 52.241 0 Td [(Curren)28(t)-333(heap)-334(o)-28(ccupancy;)]TJ -0 g 0 G -/F27 9.9626 Tf -52.241 -20.096 Td [(insert)]TJ -0 g 0 G -/F8 9.9626 Tf 33.473 0 Td [(Add)-333(an)-334(item)-333(\050or)-333(an)-334(i)1(te)-1(m)-333(and)-333(its)-334(i)1(ndex\051;)]TJ -0 g 0 G - 133.401 -29.888 Td [(26)]TJ + 166.874 -29.888 Td [(26)]TJ 0 g 0 G ET endstream endobj -966 0 obj +965 0 obj << -/Length 758 +/Length 3656 >> stream 0 g 0 G 0 g 0 G 0 g 0 G +0 g 0 G +0 g 0 G +0 g 0 G +0 g 0 G BT -/F27 9.9626 Tf 99.895 706.129 Td [(get)]TJ +/F47 8.9664 Tf 126.497 705.133 Td [(type)-525(psb_Tprec_type)]TJ 9.414 -10.959 Td [(class\050psb_T_base_prec_type\051,)-525(allocatable)-525(::)-525(prec)]TJ -9.414 -10.959 Td [(end)-525(type)-525(psb_Tprec_type)]TJ +0 g 0 G +/F8 9.9626 Tf -14.633 -38.799 Td [(Figure)-333(6:)-445(The)-333(PSBLAS)-333(de\014ned)-334(data)-333(t)28(yp)-28(e)-333(that)-333(c)-1(on)28(tains)-333(a)-333(preconditioner.)]TJ +0 g 0 G +0 g 0 G +/F16 11.9552 Tf -11.969 -31.825 Td [(3.5)-1125(Heap)-375(data)-375(structure)]TJ/F8 9.9626 Tf 0 -18.39 Td [(Among)-393(the)-393(to)-28(ols)-393(routines)-393(of)-393(sec.)]TJ +0 0 1 rg 0 0 1 RG + [-393(6)]TJ +0 g 0 G + [(,)-408(w)28(e)-393(ha)28(v)27(e)-393(a)-393(n)28(um)28(b)-28(er)-393(of)-393(sorting)-393(utilities;)-423(the)]TJ 0 -11.955 Td [(heap)-333(sort)-334(is)-333(implemen)28(ted)-334(in)-333(terms)-333(of)-334(heaps)-333(ha)28(ving)-333(the)-334(follo)28(wing)-333(signatures:)]TJ +0 g 0 G +/F30 9.9626 Tf 0 -19.925 Td [(psb)]TJ ET q -1 0 0 1 116.018 706.328 cm +1 0 0 1 116.214 562.52 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 119.352 562.321 Td [(T)]TJ +ET +q +1 0 0 1 125.21 562.52 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 128.348 562.321 Td [(heap)]TJ +0 g 0 G +/F8 9.9626 Tf 25.903 0 Td [(:)-425(a)-295(heap)-296(con)28(taining)-295(elemen)28(ts)-295(of)-295(t)27(yp)-27(e)-296(T,)-295(where)-295(T)-295(can)-295(b)-28(e)]TJ/F30 9.9626 Tf 242.282 0 Td [(i,s,c,d,z)]TJ/F8 9.9626 Tf -271.731 -11.955 Td [(for)-333(in)28(tege)-1(r)1(,)-334(real)-333(and)-333(complex)-334(data;)]TJ +0 g 0 G +/F30 9.9626 Tf -24.907 -19.925 Td [(psb)]TJ +ET +q +1 0 0 1 116.214 530.64 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 119.352 530.441 Td [(T)]TJ +ET +q +1 0 0 1 125.21 530.64 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 128.348 530.441 Td [(idx)]TJ +ET +q +1 0 0 1 144.667 530.64 cm +[]0 d 0 J 0.398 w 0 0 m 3.138 0 l S +Q +BT +/F30 9.9626 Tf 147.805 530.441 Td [(heap)]TJ +0 g 0 G +/F8 9.9626 Tf 25.903 0 Td [(:)-408(a)-260(heap)-260(con)28(taining)-260(elemen)28(ts)-260(of)-260(t)28(yp)-28(e)-260(T,)-260(as)-259(ab)-28(o)28(v)27(e,)-274(together)-260(with)]TJ -48.906 -11.956 Td [(an)-333(in)28(tege)-1(r)-333(index.)]TJ -24.907 -19.925 Td [(Giv)28(en)-334(a)-333(heap)-333(ob)-56(ject,)-333(the)-333(follo)27(wing)-333(metho)-28(ds)-333(are)-333(de\014ned)-334(on)-333(it:)]TJ +0 g 0 G +/F27 9.9626 Tf 0 -19.925 Td [(init)]TJ +0 g 0 G +/F8 9.9626 Tf 22.167 0 Td [(Initialize)-333(memory;)-334(also)-333(c)28(ho)-28(ose)-334(ascending)-333(or)-333(descending)-333(order;)]TJ +0 g 0 G +/F27 9.9626 Tf -22.167 -19.926 Td [(ho)32(wman)32(y)]TJ +0 g 0 G +/F8 9.9626 Tf 52.242 0 Td [(Curren)28(t)-333(heap)-334(o)-28(ccupan)1(c)-1(y;)]TJ +0 g 0 G +/F27 9.9626 Tf -52.242 -19.925 Td [(insert)]TJ +0 g 0 G +/F8 9.9626 Tf 33.473 0 Td [(Add)-333(an)-334(item)-333(\050or)-333(an)-334(item)-333(and)-333(its)-334(ind)1(e)-1(x)1(\051;)]TJ +0 g 0 G +/F27 9.9626 Tf -33.473 -19.925 Td [(get)]TJ +ET +q +1 0 0 1 116.018 419.058 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 119.455 706.129 Td [(\014rst)]TJ +/F27 9.9626 Tf 119.455 418.859 Td [(\014rst)]TJ 0 g 0 G /F8 9.9626 Tf 25.039 0 Td [(Remo)28(v)27(e)-333(and)-333(return)-333(the)-334(\014rst)-333(elemen)28(t;)]TJ 0 g 0 G @@ -7761,7 +7764,7 @@ BT 0 g 0 G /F8 9.9626 Tf 23.703 0 Td [(Release)-334(memory)84(.)]TJ -23.703 -19.925 Td [(These)-333(ob)-56(jects)-333(are)-334(used)-333(in)-333(MLD2P4)-334(to)-333(implemen)28(t)-334(the)-333(factorization)-333(algorithms.)]TJ 0 g 0 G - 166.875 -555.915 Td [(27)]TJ + 166.875 -268.645 Td [(27)]TJ 0 g 0 G ET @@ -8316,27 +8319,23 @@ endobj << /Type /ObjStm /N 100 -/First 888 -/Length 10180 +/First 889 +/Length 10219 >> stream -115 0 908 56 915 148 917 262 119 319 123 376 127 432 914 489 919 581 921 695 -131 751 135 807 918 863 924 955 926 1069 139 1126 143 1182 923 1238 928 1330 930 1444 -147 1500 151 1556 927 1612 932 1704 934 1818 155 1875 159 1932 163 1989 931 2046 938 2138 -935 2280 936 2427 940 2573 167 2629 171 2685 941 2741 937 2798 944 2903 946 3017 942 3074 -175 3131 179 3188 183 3245 187 3302 943 3359 950 3451 947 3593 948 3738 952 3883 191 3939 -949 3995 958 4100 955 4242 956 4388 960 4535 195 4592 199 4649 961 4705 963 4762 204 4819 -957 4876 965 4994 967 5108 964 5164 969 5243 971 5357 208 5414 968 5471 980 5550 972 5724 -973 5869 974 6012 975 6157 976 6302 977 6445 982 6590 212 6646 954 6702 979 6758 986 6889 -978 7039 983 7185 984 7327 988 7472 985 7529 995 7634 989 7800 990 7942 991 8087 992 8229 -993 8373 997 8518 216 8574 998 8630 994 8687 1002 8831 1000 8969 1004 9115 1005 9174 1006 9233 -% 115 0 obj -<< -/D [909 0 R /XYZ 99.895 279.894 null] ->> +908 0 915 92 917 206 115 263 119 320 123 377 914 434 919 526 921 640 127 696 +131 752 918 808 924 900 926 1014 135 1071 139 1128 923 1184 928 1276 930 1390 143 1446 +147 1502 151 1558 927 1614 932 1706 934 1820 155 1877 931 1934 938 2026 935 2168 936 2315 +940 2461 159 2517 163 2573 167 2629 171 2685 941 2741 937 2798 944 2903 946 3017 942 3074 +175 3131 179 3188 183 3245 943 3302 950 3394 947 3536 948 3681 952 3826 187 3882 949 3938 +958 4030 955 4164 960 4310 191 4367 195 4424 199 4481 961 4538 957 4595 964 4713 956 4847 +966 4994 962 5050 204 5107 963 5163 969 5281 971 5395 208 5452 968 5509 980 5588 972 5762 +973 5907 974 6050 975 6195 976 6340 977 6483 982 6628 212 6684 954 6740 979 6796 986 6927 +978 7077 983 7223 984 7365 988 7510 985 7567 995 7672 989 7838 990 7980 991 8125 992 8267 +993 8411 997 8556 216 8612 998 8668 994 8725 1002 8869 1000 9007 1004 9153 1005 9212 1006 9271 % 908 0 obj << -/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R >> +/Font << /F27 560 0 R /F8 561 0 R /F30 769 0 R >> /ProcSet [ /PDF /Text ] >> % 915 0 obj @@ -8351,17 +8350,17 @@ stream << /D [915 0 R /XYZ 149.705 753.953 null] >> -% 119 0 obj +% 115 0 obj << /D [915 0 R /XYZ 150.705 718.084 null] >> +% 119 0 obj +<< +/D [915 0 R /XYZ 150.705 528.904 null] +>> % 123 0 obj << -/D [915 0 R /XYZ 150.705 538.16 null] ->> -% 127 0 obj -<< -/D [915 0 R /XYZ 150.705 334.326 null] +/D [915 0 R /XYZ 150.705 327.768 null] >> % 914 0 obj << @@ -8380,13 +8379,13 @@ stream << /D [919 0 R /XYZ 98.895 753.953 null] >> -% 131 0 obj +% 127 0 obj << /D [919 0 R /XYZ 99.895 718.084 null] >> -% 135 0 obj +% 131 0 obj << -/D [919 0 R /XYZ 99.895 363.788 null] +/D [919 0 R /XYZ 99.895 477.598 null] >> % 918 0 obj << @@ -8405,17 +8404,17 @@ stream << /D [924 0 R /XYZ 149.705 753.953 null] >> +% 135 0 obj +<< +/D [924 0 R /XYZ 150.705 718.084 null] +>> % 139 0 obj << -/D [924 0 R /XYZ 150.705 652.99 null] ->> -% 143 0 obj -<< -/D [924 0 R /XYZ 150.705 364.65 null] +/D [924 0 R /XYZ 150.705 383.68 null] >> % 923 0 obj << -/Font << /F27 560 0 R /F8 561 0 R /F30 769 0 R >> +/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R >> /ProcSet [ /PDF /Text ] >> % 928 0 obj @@ -8430,13 +8429,17 @@ stream << /D [928 0 R /XYZ 98.895 753.953 null] >> -% 147 0 obj +% 143 0 obj << /D [928 0 R /XYZ 99.895 718.084 null] >> +% 147 0 obj +<< +/D [928 0 R /XYZ 99.895 483.063 null] +>> % 151 0 obj << -/D [928 0 R /XYZ 99.895 487.217 null] +/D [928 0 R /XYZ 99.895 248.041 null] >> % 927 0 obj << @@ -8457,19 +8460,11 @@ stream >> % 155 0 obj << -/D [932 0 R /XYZ 150.705 718.084 null] ->> -% 159 0 obj -<< -/D [932 0 R /XYZ 150.705 325.491 null] ->> -% 163 0 obj -<< -/D [932 0 R /XYZ 150.705 193.501 null] +/D [932 0 R /XYZ 150.705 476.867 null] >> % 931 0 obj << -/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R >> +/Font << /F27 560 0 R /F8 561 0 R /F30 769 0 R >> /ProcSet [ /PDF /Text ] >> % 938 0 obj @@ -8486,7 +8481,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [199.382 344.354 206.356 355.203] +/Rect [199.382 165.213 206.356 176.061] /A << /S /GoTo /D (section.6) >> >> % 936 0 obj @@ -8494,28 +8489,36 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [292.368 307.977 299.342 318.825] +/Rect [292.368 129.347 299.342 140.196] /A << /S /GoTo /D (figure.5) >> >> % 940 0 obj << /D [938 0 R /XYZ 98.895 753.953 null] >> +% 159 0 obj +<< +/D [938 0 R /XYZ 99.895 718.084 null] +>> +% 163 0 obj +<< +/D [938 0 R /XYZ 99.895 590.059 null] +>> % 167 0 obj << -/D [938 0 R /XYZ 99.895 598.678 null] +/D [938 0 R /XYZ 99.895 402.035 null] >> % 171 0 obj << -/D [938 0 R /XYZ 99.895 414.464 null] +/D [938 0 R /XYZ 99.895 233.858 null] >> % 941 0 obj << -/D [938 0 R /XYZ 121.151 383.153 null] +/D [938 0 R /XYZ 121.151 204.012 null] >> % 937 0 obj << -/Font << /F27 560 0 R /F8 561 0 R /F16 558 0 R /F30 769 0 R >> +/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R /F16 558 0 R >> /ProcSet [ /PDF /Text ] >> % 944 0 obj @@ -8532,27 +8535,23 @@ stream >> % 942 0 obj << -/D [944 0 R /XYZ 208.488 610.432 null] +/D [944 0 R /XYZ 208.488 433.055 null] >> % 175 0 obj << -/D [944 0 R /XYZ 150.705 576.609 null] +/D [944 0 R /XYZ 150.705 391.443 null] >> % 179 0 obj << -/D [944 0 R /XYZ 150.705 560.207 null] +/D [944 0 R /XYZ 150.705 374.163 null] >> % 183 0 obj << -/D [944 0 R /XYZ 150.705 388.328 null] ->> -% 187 0 obj -<< -/D [944 0 R /XYZ 150.705 216.449 null] +/D [944 0 R /XYZ 150.705 195.076 null] >> % 943 0 obj << -/Font << /F30 769 0 R /F8 561 0 R /F27 560 0 R >> +/Font << /F27 560 0 R /F8 561 0 R /F30 769 0 R >> /ProcSet [ /PDF /Text ] >> % 950 0 obj @@ -8569,7 +8568,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [382.088 613.077 389.062 623.925] +/Rect [382.088 385.356 389.062 396.204] /A << /S /GoTo /D (table.1) >> >> % 948 0 obj @@ -8577,20 +8576,20 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [382.088 480.661 389.062 491.509] +/Rect [382.088 241.508 389.062 252.356] /A << /S /GoTo /D (table.1) >> >> % 952 0 obj << /D [950 0 R /XYZ 98.895 753.953 null] >> -% 191 0 obj +% 187 0 obj << -/D [950 0 R /XYZ 99.895 367.962 null] +/D [950 0 R /XYZ 99.895 613.581 null] >> % 949 0 obj << -/Font << /F27 560 0 R /F8 561 0 R /F30 769 0 R /F11 755 0 R >> +/Font << /F27 560 0 R /F8 561 0 R /F30 769 0 R >> /ProcSet [ /PDF /Text ] >> % 958 0 obj @@ -8600,68 +8599,73 @@ stream /Resources 957 0 R /MediaBox [0 0 595.276 841.89] /Parent 953 0 R -/Annots [ 955 0 R 956 0 R ] +/Annots [ 955 0 R ] >> % 955 0 obj << /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [177.685 453.572 184.659 464.697] +/Rect [177.685 152.981 184.659 164.106] /A << /S /GoTo /D (figure.6) >> >> +% 960 0 obj +<< +/D [958 0 R /XYZ 149.705 753.953 null] +>> +% 191 0 obj +<< +/D [958 0 R /XYZ 150.705 718.084 null] +>> +% 195 0 obj +<< +/D [958 0 R /XYZ 150.705 430.016 null] +>> +% 199 0 obj +<< +/D [958 0 R /XYZ 150.705 226.068 null] +>> +% 961 0 obj +<< +/D [958 0 R /XYZ 308.372 168.146 null] +>> +% 957 0 obj +<< +/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R /F11 755 0 R /F16 558 0 R >> +/ProcSet [ /PDF /Text ] +>> +% 964 0 obj +<< +/Type /Page +/Contents 965 0 R +/Resources 963 0 R +/MediaBox [0 0 595.276 841.89] +/Parent 953 0 R +/Annots [ 956 0 R ] +>> % 956 0 obj << /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [297.652 273.706 304.626 284.554] +/Rect [246.843 591.268 253.817 602.116] /A << /S /GoTo /D (section.6) >> >> -% 960 0 obj +% 966 0 obj << -/D [958 0 R /XYZ 149.705 753.953 null] +/D [964 0 R /XYZ 98.895 753.953 null] >> -% 195 0 obj +% 962 0 obj << -/D [958 0 R /XYZ 150.705 718.084 null] ->> -% 199 0 obj -<< -/D [958 0 R /XYZ 150.705 525.15 null] ->> -% 961 0 obj -<< -/D [958 0 R /XYZ 308.372 468.737 null] ->> -% 963 0 obj -<< -/D [958 0 R /XYZ 206.288 347.218 null] +/D [964 0 R /XYZ 155.478 656.371 null] >> % 204 0 obj << -/D [958 0 R /XYZ 150.705 307.161 null] +/D [964 0 R /XYZ 99.895 622.553 null] >> -% 957 0 obj +% 963 0 obj << -/Font << /F27 560 0 R /F30 769 0 R /F8 561 0 R /F16 558 0 R /F47 962 0 R >> -/ProcSet [ /PDF /Text ] ->> -% 965 0 obj -<< -/Type /Page -/Contents 966 0 R -/Resources 964 0 R -/MediaBox [0 0 595.276 841.89] -/Parent 953 0 R ->> -% 967 0 obj -<< -/D [965 0 R /XYZ 98.895 753.953 null] ->> -% 964 0 obj -<< -/Font << /F27 560 0 R /F8 561 0 R >> +/Font << /F47 967 0 R /F8 561 0 R /F16 558 0 R /F30 769 0 R /F27 560 0 R >> /ProcSet [ /PDF /Text ] >> % 969 0 obj @@ -11415,7 +11419,7 @@ endstream endobj 1149 0 obj << -/Length 6975 +/Length 6976 >> stream 0 g 0 G @@ -11430,114 +11434,114 @@ BT 0 g 0 G [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -18.453 Td [(y)]TJ +/F27 9.9626 Tf -24.906 -18.597 Td [(y)]TJ 0 g 0 G -/F8 9.9626 Tf 11.028 0 Td [(the)-333(lo)-28(cal)-333(p)-28(ortion)-333(of)-334(global)-333(dense)-333(matrix)]TJ/F11 9.9626 Tf 176.118 0 Td [(y)]TJ/F8 9.9626 Tf 5.242 0 Td [(.)]TJ -167.482 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.956 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(required)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.955 Td [(Sp)-28(eci\014ed)-255(as:)-405(a)-255(rank)-254(one)-255(or)-255(t)28(w)27(o)-254(arra)27(y)-254(or)-255(an)-255(ob)-56(j)1(e)-1(ct)-254(of)-255(t)28(yp)-28(e)]TJ +/F8 9.9626 Tf 11.028 0 Td [(the)-333(lo)-28(cal)-333(p)-28(ortion)-333(of)-334(global)-333(dense)-333(matrix)]TJ/F11 9.9626 Tf 176.118 0 Td [(y)]TJ/F8 9.9626 Tf 5.242 0 Td [(.)]TJ -167.482 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(required)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.955 Td [(Sp)-28(eci\014ed)-255(as:)-405(a)-255(rank)-254(one)-255(or)-255(t)28(w)27(o)-254(arra)27(y)-254(or)-255(an)-255(ob)-56(j)1(e)-1(ct)-254(of)-255(t)28(yp)-28(e)]TJ 0 0 1 rg 0 0 1 RG /F30 9.9626 Tf 244.743 0 Td [(psb)]TJ ET q -1 0 0 1 436.673 592.233 cm +1 0 0 1 436.673 592.09 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 439.811 592.034 Td [(T)]TJ +/F30 9.9626 Tf 439.811 591.891 Td [(T)]TJ ET q -1 0 0 1 445.669 592.233 cm +1 0 0 1 445.669 592.09 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 448.807 592.034 Td [(vect)]TJ +/F30 9.9626 Tf 448.807 591.891 Td [(vect)]TJ ET q -1 0 0 1 470.356 592.233 cm +1 0 0 1 470.356 592.09 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 473.495 592.034 Td [(type)]TJ +/F30 9.9626 Tf 473.495 591.891 Td [(type)]TJ 0 g 0 G -/F8 9.9626 Tf -297.884 -11.955 Td [(con)28(taining)-345(n)28(um)28(b)-28(ers)-345(of)-345(t)28(yp)-28(e)-345(sp)-28(eci\014ed)-345(in)-345(T)84(able)]TJ +/F8 9.9626 Tf -297.884 -11.956 Td [(con)28(taining)-345(n)28(um)28(b)-28(ers)-345(of)-345(t)28(yp)-28(e)-345(sp)-28(eci\014ed)-345(in)-345(T)84(able)]TJ 0 0 1 rg 0 0 1 RG [-345(12)]TJ 0 g 0 G [(.)-479(The)-345(rank)-345(of)]TJ/F11 9.9626 Tf 275.087 0 Td [(y)]TJ/F8 9.9626 Tf 8.678 0 Td [(m)28(ust)-345(b)-28(e)]TJ -283.765 -11.955 Td [(the)-333(same)-334(of)]TJ/F11 9.9626 Tf 53.467 0 Td [(x)]TJ/F8 9.9626 Tf 5.694 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -84.067 -18.454 Td [(desc)]TJ +/F27 9.9626 Tf -84.067 -18.597 Td [(desc)]TJ ET q -1 0 0 1 172.619 549.87 cm +1 0 0 1 172.619 549.583 cm []0 d 0 J 0.398 w 0 0 m 3.437 0 l S Q BT -/F27 9.9626 Tf 176.057 549.67 Td [(a)]TJ +/F27 9.9626 Tf 176.057 549.383 Td [(a)]TJ 0 g 0 G /F8 9.9626 Tf 10.55 0 Td [(con)28(tains)-334(data)-333(structures)-333(for)-333(c)-1(omm)28(unications.)]TJ -10.996 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(required)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.548 0 Td [(.)]TJ -43.034 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(an)-333(ob)-55(ject)-334(of)-333(t)28(yp)-28(e)]TJ 0 0 1 rg 0 0 1 RG /F30 9.9626 Tf 135.659 0 Td [(psb)]TJ ET q -1 0 0 1 327.588 502.049 cm +1 0 0 1 327.588 501.762 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 330.727 501.85 Td [(desc)]TJ +/F30 9.9626 Tf 330.727 501.563 Td [(desc)]TJ ET q -1 0 0 1 352.275 502.049 cm +1 0 0 1 352.275 501.762 cm []0 d 0 J 0.398 w 0 0 m 3.138 0 l S Q BT -/F30 9.9626 Tf 355.414 501.85 Td [(type)]TJ +/F30 9.9626 Tf 355.414 501.563 Td [(type)]TJ 0 g 0 G /F8 9.9626 Tf 20.921 0 Td [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -225.63 -18.454 Td [(trans)]TJ +/F27 9.9626 Tf -225.63 -18.597 Td [(trans)]TJ 0 g 0 G /F8 9.9626 Tf 30.609 0 Td [(indicates)-333(what)-334(kind)-333(of)-333(op)-28(eration)-333(to)-333(p)-28(erform.)]TJ 0 g 0 G -/F27 9.9626 Tf -5.703 -18.453 Td [(trans)-383(=)-384(N)]TJ +/F27 9.9626 Tf -5.703 -18.597 Td [(trans)-383(=)-384(N)]TJ 0 g 0 G /F8 9.9626 Tf 56.124 0 Td [(the)-333(op)-28(eration)-333(is)-334(sp)-28(eci\014ed)-333(b)28(y)-333(equation)]TJ 0 0 1 rg 0 0 1 RG [-334(1)]TJ 0 g 0 G 0 g 0 G -/F27 9.9626 Tf -56.124 -14.469 Td [(trans)-383(=)-384(T)]TJ +/F27 9.9626 Tf -56.124 -14.612 Td [(trans)-383(=)-384(T)]TJ 0 g 0 G /F8 9.9626 Tf 55.128 0 Td [(the)-333(op)-28(eration)-333(is)-334(sp)-28(eci\014ed)-333(b)28(y)-333(equation)]TJ 0 0 1 rg 0 0 1 RG [-334(2)]TJ 0 g 0 G 0 g 0 G -/F27 9.9626 Tf -55.128 -14.468 Td [(trans)-383(=)-384(C)]TJ +/F27 9.9626 Tf -55.128 -14.612 Td [(trans)-383(=)-384(C)]TJ 0 g 0 G /F8 9.9626 Tf 55.433 0 Td [(the)-333(op)-28(eration)-333(is)-334(sp)-27(ec)-1(i\014)1(e)-1(d)-333(b)28(y)-333(equation)]TJ 0 0 1 rg 0 0 1 RG [-334(3)]TJ 0 g 0 G - -55.433 -18.453 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(global)]TJ/F8 9.9626 Tf -32.379 -11.956 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(optional)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.955 Td [(Default:)]TJ/F11 9.9626 Tf 39.436 0 Td [(tr)-28(ans)]TJ/F8 9.9626 Tf 27.052 0 Td [(=)]TJ/F11 9.9626 Tf 10.517 0 Td [(N)]TJ/F8 9.9626 Tf -77.005 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(c)28(haracter)-334(v)56(ariable.)]TJ + -55.433 -18.597 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(global)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(optional)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.955 Td [(Default:)]TJ/F11 9.9626 Tf 39.436 0 Td [(tr)-28(ans)]TJ/F8 9.9626 Tf 27.052 0 Td [(=)]TJ/F11 9.9626 Tf 10.517 0 Td [(N)]TJ/F8 9.9626 Tf -77.005 -11.956 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(c)28(haracter)-334(v)56(ariable.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -18.454 Td [(w)32(ork)]TJ +/F27 9.9626 Tf -24.906 -18.596 Td [(w)32(ork)]TJ 0 g 0 G -/F8 9.9626 Tf 29.431 0 Td [(w)28(ork)-334(arr)1(a)27(y)84(.)]TJ -4.525 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(optional)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.955 Td [(Sp)-28(eci\014ed)-487(as:)-753(a)-487(rank)-488(one)-487(arra)28(y)-488(of)-487(the)-488(same)-487(t)27(yp)-27(e)-488(of)]TJ/F11 9.9626 Tf 239.183 0 Td [(x)]TJ/F8 9.9626 Tf 10.551 0 Td [(and)]TJ/F11 9.9626 Tf 20.907 0 Td [(y)]TJ/F8 9.9626 Tf 10.099 0 Td [(with)-487(the)]TJ -280.74 -11.955 Td [(T)83(AR)28(GET)-333(attribute.)]TJ +/F8 9.9626 Tf 29.431 0 Td [(w)28(ork)-334(arr)1(a)27(y)84(.)]TJ -4.525 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(optional)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.955 Td [(Sp)-28(eci\014ed)-487(as:)-753(a)-487(rank)-488(one)-487(arra)28(y)-488(of)-487(the)-488(same)-487(t)27(yp)-27(e)-488(of)]TJ/F11 9.9626 Tf 239.183 0 Td [(x)]TJ/F8 9.9626 Tf 10.551 0 Td [(and)]TJ/F11 9.9626 Tf 20.907 0 Td [(y)]TJ/F8 9.9626 Tf 10.099 0 Td [(with)-487(the)]TJ -280.74 -11.955 Td [(T)83(AR)28(GET)-333(attribute.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -18.454 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -24.906 -18.597 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -18.453 Td [(y)]TJ + 0 -18.597 Td [(y)]TJ 0 g 0 G -/F8 9.9626 Tf 11.028 0 Td [(the)-333(lo)-28(cal)-333(p)-28(ortion)-333(of)-334(result)-333(matrix)]TJ/F11 9.9626 Tf 147.364 0 Td [(y)]TJ/F8 9.9626 Tf 5.242 0 Td [(.)]TJ -138.728 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.956 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(required)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.955 Td [(Sp)-28(eci\014ed)-474(as:)-727(an)-475(arra)28(y)-475(of)-474(rank)-475(one)-474(or)-475(t)28(w)28(o)-475(con)28(taining)-474(n)27(um)28(b)-28(ers)-474(of)-475(t)28(yp)-28(e)]TJ 0 -11.955 Td [(sp)-28(eci\014ed)-333(in)-333(T)83(able)]TJ +/F8 9.9626 Tf 11.028 0 Td [(the)-333(lo)-28(cal)-333(p)-28(ortion)-333(of)-334(result)-333(matrix)]TJ/F11 9.9626 Tf 147.364 0 Td [(y)]TJ/F8 9.9626 Tf 5.242 0 Td [(.)]TJ -138.728 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(required)]TJ/F8 9.9626 Tf -29.612 -11.956 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.955 Td [(Sp)-28(eci\014ed)-474(as:)-727(an)-475(arra)28(y)-475(of)-474(rank)-475(one)-474(or)-475(t)28(w)28(o)-475(con)28(taining)-474(n)27(um)28(b)-28(ers)-474(of)-475(t)28(yp)-28(e)]TJ 0 -11.955 Td [(sp)-28(eci\014ed)-333(in)-333(T)83(able)]TJ 0 0 1 rg 0 0 1 RG [-333(12)]TJ 0 g 0 G [(.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.906 -18.454 Td [(info)]TJ +/F27 9.9626 Tf -24.906 -18.597 Td [(info)]TJ 0 g 0 G -/F8 9.9626 Tf 23.758 0 Td [(Error)-333(co)-28(de.)]TJ 1.148 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(required)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(out)]TJ/F8 9.9626 Tf 16.549 0 Td [(.)]TJ -50.035 -11.955 Td [(An)-333(in)28(te)-1(ger)-333(v)56(alue;)-334(0)-333(means)-333(no)-334(error)-333(has)-333(b)-28(een)-333(detec)-1(t)1(e)-1(d.)]TJ +/F8 9.9626 Tf 23.758 0 Td [(Error)-333(co)-28(de.)]TJ 1.148 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf -32.379 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.612 0 Td [(required)]TJ/F8 9.9626 Tf -29.612 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(out)]TJ/F8 9.9626 Tf 16.549 0 Td [(.)]TJ -50.035 -11.956 Td [(An)-333(in)28(te)-1(ger)-333(v)56(alue;)-334(0)-333(means)-333(no)-334(error)-333(has)-333(b)-28(een)-333(detec)-1(t)1(e)-1(d.)]TJ 0 g 0 G - 141.968 -38.108 Td [(48)]TJ + 141.968 -36.529 Td [(48)]TJ 0 g 0 G ET @@ -12647,19 +12651,19 @@ endobj /Type /ObjStm /N 100 /First 995 -/Length 12718 +/Length 12713 >> stream 1116 0 248 58 1117 115 1113 174 1122 318 1119 466 1120 611 1124 758 252 817 1126 875 1121 934 1133 1080 1127 1246 1128 1393 1129 1538 1130 1682 1135 1829 256 1887 1136 1944 1137 2003 -1138 2062 1139 2121 1132 2180 1148 2337 1131 2539 1140 2686 1141 2830 1142 2977 1143 3124 1144 3275 -1145 3426 1146 3577 1150 3724 1147 3783 1154 3889 1151 4028 1156 4174 260 4232 1157 4289 1153 4348 -1166 4519 1152 4712 1159 4860 1160 5004 1161 5151 1162 5298 1163 5442 1164 5589 1168 5735 1165 5794 -1172 5926 1169 6074 1170 6221 1174 6368 1171 6426 1177 6532 1175 6671 1179 6819 264 6878 1176 6936 -1185 7016 1180 7173 1181 7317 1182 7464 1187 7611 268 7669 1188 7726 1189 7785 1190 7843 1191 7901 -1184 7959 1195 8091 1199 8239 1200 8366 1201 8409 1202 8616 1203 8854 1204 9130 1183 9366 1193 9513 -1197 9659 1198 9718 1194 9777 1208 9925 1210 10043 1207 10101 1217 10182 1213 10339 1214 10483 1215 10630 -1219 10776 272 10835 1220 10893 1221 10952 1222 11011 1223 11070 1216 11129 1229 11274 1224 11431 1226 11578 +1138 2062 1139 2121 1132 2180 1148 2337 1131 2539 1140 2686 1141 2829 1142 2975 1143 3122 1144 3273 +1145 3424 1146 3574 1150 3719 1147 3778 1154 3884 1151 4023 1156 4169 260 4227 1157 4284 1153 4343 +1166 4514 1152 4707 1159 4855 1160 4999 1161 5146 1162 5293 1163 5437 1164 5584 1168 5730 1165 5789 +1172 5921 1169 6069 1170 6216 1174 6363 1171 6421 1177 6527 1175 6666 1179 6814 264 6873 1176 6931 +1185 7011 1180 7168 1181 7312 1182 7459 1187 7606 268 7664 1188 7721 1189 7780 1190 7838 1191 7896 +1184 7954 1195 8086 1199 8234 1200 8361 1201 8404 1202 8611 1203 8849 1204 9125 1183 9361 1193 9508 +1197 9654 1198 9713 1194 9772 1208 9920 1210 10038 1207 10096 1217 10177 1213 10334 1214 10478 1215 10625 +1219 10771 272 10830 1220 10888 1221 10947 1222 11006 1223 11065 1216 11124 1229 11269 1224 11426 1226 11573 % 1116 0 obj << /D [1114 0 R /XYZ 98.895 753.953 null] @@ -12811,7 +12815,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [419.358 588.824 495.412 599.949] +/Rect [419.358 588.68 495.412 599.805] /A << /S /GoTo /D (vdata) >> >> % 1141 0 obj @@ -12819,7 +12823,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [377.029 577.145 388.984 587.994] +/Rect [377.029 577.002 388.984 587.85] /A << /S /GoTo /D (table.12) >> >> % 1142 0 obj @@ -12827,7 +12831,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [310.273 498.639 377.331 509.764] +/Rect [310.273 498.352 377.331 509.477] /A << /S /GoTo /D (descdata) >> >> % 1143 0 obj @@ -12835,7 +12839,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [397.199 462.009 404.172 472.858] +/Rect [397.199 461.435 404.172 472.284] /A << /S /GoTo /D (equation.4.1) >> >> % 1144 0 obj @@ -12843,7 +12847,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [396.202 447.541 403.176 458.389] +/Rect [396.202 446.823 403.176 457.672] /A << /S /GoTo /D (equation.4.2) >> >> % 1145 0 obj @@ -12851,7 +12855,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [396.507 433.073 403.481 443.921] +/Rect [396.507 432.212 403.481 443.06] /A << /S /GoTo /D (equation.4.3) >> >> % 1146 0 obj @@ -12859,7 +12863,7 @@ stream /Type /Annot /Subtype /Link /Border[0 0 0]/H/I/C[1 0 0] -/Rect [253.818 191.887 265.774 202.735] +/Rect [253.818 190.452 265.774 201.3] /A << /S /GoTo /D (table.12) >> >> % 1150 0 obj @@ -19912,7 +19916,7 @@ endstream endobj 1626 0 obj << -/Length 6189 +/Length 6213 >> stream 0 g 0 G @@ -19928,54 +19932,54 @@ BT /F16 11.9552 Tf 124.986 706.129 Td [(nrm2)-375(|)-375(Global)-375(2-norm)-375(reduction)]TJ 0 g 0 G 0 g 0 G -/F30 9.9626 Tf -25.091 -18.389 Td [(call)-525(psb_nrm2\050icontxt,)-525(dat,)-525(root\051)]TJ/F8 9.9626 Tf 14.944 -19.604 Td [(This)-425(subroutine)-426(imp)1(le)-1(men)28(ts)-425(a)-425(2-norm)-426(v)56(alue)-425(reduction)-426(op)-27(eration)-426(based)-425(on)]TJ -14.944 -11.955 Td [(the)-333(underlying)-334(comm)28(unication)-333(library)83(.)]TJ +/F30 9.9626 Tf -25.091 -18.389 Td [(call)-525(psb_nrm2\050icontxt,)-525(dat,)-525(root\051)]TJ/F8 9.9626 Tf 14.944 -19.794 Td [(This)-425(subroutine)-426(imp)1(le)-1(men)28(ts)-425(a)-425(2-norm)-426(v)56(alue)-425(reduction)-426(op)-27(eration)-426(based)-425(on)]TJ -14.944 -11.955 Td [(the)-333(underlying)-334(comm)28(unication)-333(library)83(.)]TJ 0 g 0 G -/F27 9.9626 Tf 0 -18.074 Td [(T)32(yp)-32(e:)]TJ +/F27 9.9626 Tf 0 -18.226 Td [(T)32(yp)-32(e:)]TJ 0 g 0 G /F8 9.9626 Tf 33.797 0 Td [(Sync)28(hronous.)]TJ 0 g 0 G -/F27 9.9626 Tf -33.797 -19 Td [(On)-383(En)32(try)]TJ +/F27 9.9626 Tf -33.797 -19.076 Td [(On)-383(En)32(try)]TJ 0 g 0 G 0 g 0 G - 0 -19 Td [(icon)32(txt)]TJ + 0 -19.076 Td [(icon)32(txt)]TJ 0 g 0 G /F8 9.9626 Tf 39.989 0 Td [(the)-333(comm)27(unication)-333(con)28(text)-333(iden)27(tifyin)1(g)-334(the)-333(virtual)-333(parallel)-334(mac)28(hine.)]TJ -15.082 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(global)]TJ/F8 9.9626 Tf 29.756 0 Td [(.)]TJ -62.135 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf 41.898 0 Td [(.)]TJ -71.509 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(an)-333(in)28(teger)-333(v)55(ariable.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.907 -19 Td [(dat)]TJ +/F27 9.9626 Tf -24.907 -19.076 Td [(dat)]TJ 0 g 0 G -/F8 9.9626 Tf 21.371 0 Td [(The)-333(lo)-28(cal)-334(con)28(tribution)-333(to)-333(the)-334(global)-333(minim)28(um.)]TJ 3.536 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -55.452 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf 41.898 0 Td [(.)]TJ -71.509 -11.956 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.955 Td [(Sp)-28(eci\014ed)-421(as:)-619(a)-421(real)-421(v)55(ariable,)-443(whic)28(h)-421(ma)28(y)-421(b)-28(e)-421(a)-421(scalar,)-443(or)-421(a)-420(rank)-421(1)-421(arra)28(y)83(.)]TJ 0 -11.955 Td [(Kind,)-333(rank)-333(and)-334(size)-333(m)28(ust)-334(agree)-333(on)-333(all)-334(pro)-27(ce)-1(sses.)]TJ +/F8 9.9626 Tf 21.371 0 Td [(The)-333(lo)-28(cal)-334(con)28(tribution)-333(to)-333(the)-334(global)-333(minim)28(um.)]TJ 3.536 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(lo)-32(cal)]TJ/F8 9.9626 Tf 23.073 0 Td [(.)]TJ -55.452 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf 41.898 0 Td [(.)]TJ -71.509 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.956 Td [(Sp)-28(eci\014ed)-421(as:)-619(a)-421(real)-421(v)55(ariable,)-443(whic)28(h)-421(ma)28(y)-421(b)-28(e)-421(a)-421(scalar,)-443(or)-421(a)-420(rank)-421(1)-421(arra)28(y)83(.)]TJ 0 -11.955 Td [(Kind,)-333(rank)-333(and)-334(size)-333(m)28(ust)-334(agree)-333(on)-333(all)-334(pro)-27(ce)-1(sses.)]TJ 0 g 0 G -/F27 9.9626 Tf -24.907 -19 Td [(ro)-32(ot)]TJ +/F27 9.9626 Tf -24.907 -19.075 Td [(ro)-32(ot)]TJ 0 g 0 G -/F8 9.9626 Tf 25.931 0 Td [(Pro)-28(cess)-276(to)-276(hold)-276(the)-276(\014nal)-275(v)55(alue,)-287(or)]TJ/F14 9.9626 Tf 146.411 0 Td [(\000)]TJ/F8 9.9626 Tf 7.749 0 Td [(1)-276(to)-276(mak)28(e)-276(it)-276(a)28(v)55(ailable)-276(on)-276(all)-276(p)1(ro)-28(cesses.)]TJ -155.184 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(global)]TJ/F8 9.9626 Tf 29.756 0 Td [(.)]TJ -62.135 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(optional)]TJ/F8 9.9626 Tf 40.577 0 Td [(.)]TJ -70.188 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(an)-333(in)28(teger)-333(v)55(alue)]TJ/F14 9.9626 Tf 130.428 0 Td [(\000)]TJ/F8 9.9626 Tf 7.749 0 Td [(1)]TJ/F11 9.9626 Tf 7.748 0 Td [(<)]TJ/F8 9.9626 Tf 7.749 0 Td [(=)]TJ/F11 9.9626 Tf 10.516 0 Td [(r)-28(oot)-278(<)]TJ/F8 9.9626 Tf 28.543 0 Td [(=)]TJ/F11 9.9626 Tf 10.517 0 Td [(np)]TJ/F14 9.9626 Tf 13.206 0 Td [(\000)]TJ/F8 9.9626 Tf 9.962 0 Td [(1,)-333(default)-334(-1.)]TJ +/F8 9.9626 Tf 25.931 0 Td [(Pro)-28(cess)-276(to)-276(hold)-276(the)-276(\014nal)-275(v)55(alue,)-287(or)]TJ/F14 9.9626 Tf 146.411 0 Td [(\000)]TJ/F8 9.9626 Tf 7.749 0 Td [(1)-276(to)-276(mak)28(e)-276(it)-276(a)28(v)55(ailable)-276(on)-276(all)-276(p)1(ro)-28(cesses.)]TJ -155.184 -11.956 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(global)]TJ/F8 9.9626 Tf 29.756 0 Td [(.)]TJ -62.135 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(optional)]TJ/F8 9.9626 Tf 40.577 0 Td [(.)]TJ -70.188 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(in)]TJ/F8 9.9626 Tf 9.547 0 Td [(.)]TJ -43.033 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(an)-333(in)28(teger)-333(v)55(alue)]TJ/F14 9.9626 Tf 130.428 0 Td [(\000)]TJ/F8 9.9626 Tf 7.749 0 Td [(1)]TJ/F11 9.9626 Tf 7.748 0 Td [(<)]TJ/F8 9.9626 Tf 7.749 0 Td [(=)]TJ/F11 9.9626 Tf 10.516 0 Td [(r)-28(oot)-278(<)]TJ/F8 9.9626 Tf 28.543 0 Td [(=)]TJ/F11 9.9626 Tf 10.517 0 Td [(np)]TJ/F14 9.9626 Tf 13.206 0 Td [(\000)]TJ/F8 9.9626 Tf 9.962 0 Td [(1,)-333(default)-334(-1.)]TJ 0 g 0 G -/F27 9.9626 Tf -251.325 -31.559 Td [(On)-383(Return)]TJ +/F27 9.9626 Tf -251.325 -31.749 Td [(On)-383(Return)]TJ 0 g 0 G 0 g 0 G - 0 -19 Td [(dat)]TJ + 0 -19.076 Td [(dat)]TJ 0 g 0 G -/F8 9.9626 Tf 21.372 0 Td [(On)-333(destination)-333(pro)-28(cess\050es\051,)-334(the)-333(result)-333(of)-334(the)-333(2-norm)-333(reduction.)]TJ 3.535 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(global)]TJ/F8 9.9626 Tf 29.756 0 Td [(.)]TJ -62.135 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf 41.899 0 Td [(.)]TJ -71.51 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.956 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(real)-333(v)55(ariable,)-333(whic)28(h)-333(ma)27(y)-333(b)-28(e)-333(a)-333(sc)-1(alar)1(,)-334(or)-333(a)-333(rank)-334(1)-333(arra)28(y)83(.)]TJ 0 -11.955 Td [(Kind,)-333(rank)-333(and)-334(size)-333(m)28(ust)-334(agree)-333(on)-333(all)-334(pro)-27(ce)-1(sses.)]TJ/F16 11.9552 Tf -24.907 -19.603 Td [(Notes)]TJ +/F8 9.9626 Tf 21.372 0 Td [(On)-333(destination)-333(pro)-28(cess\050es\051,)-334(the)-333(result)-333(of)-334(the)-333(2-norm)-333(reduction.)]TJ 3.535 -11.955 Td [(Scop)-28(e:)]TJ/F27 9.9626 Tf 32.379 0 Td [(global)]TJ/F8 9.9626 Tf 29.756 0 Td [(.)]TJ -62.135 -11.955 Td [(T)28(yp)-28(e:)]TJ/F27 9.9626 Tf 29.611 0 Td [(required)]TJ/F8 9.9626 Tf 41.899 0 Td [(.)]TJ -71.51 -11.955 Td [(In)28(ten)28(t:)]TJ/F27 9.9626 Tf 33.486 0 Td [(inout)]TJ/F8 9.9626 Tf 26.096 0 Td [(.)]TJ -59.582 -11.955 Td [(Sp)-28(eci\014ed)-333(as:)-445(a)-333(real)-333(v)55(ariable,)-333(whic)28(h)-333(ma)27(y)-333(b)-28(e)-333(a)-333(sc)-1(alar)1(,)-334(or)-333(a)-333(rank)-334(1)-333(arra)28(y)83(.)]TJ 0 -11.955 Td [(Kind,)-333(rank)-333(and)-334(size)-333(m)28(ust)-334(agree)-333(on)-333(all)-334(pro)-27(ce)-1(sses.)]TJ/F16 11.9552 Tf -24.907 -19.794 Td [(Notes)]TJ 0 g 0 G -/F8 9.9626 Tf 12.177 -18.075 Td [(1.)]TJ +/F8 9.9626 Tf 12.177 -18.226 Td [(1.)]TJ 0 g 0 G [-500(This)-416(reduction)-416(is)-416(appropriate)-416(to)-416(compute)-416(the)-417(results)-416(of)-416(m)28(ultiple)-416(\050lo)-28(cal\051)]TJ 12.73 -11.955 Td [(NRM2)-333(op)-28(erations)-333(at)-334(the)-333(same)-334(ti)1(m)-1(e.)]TJ 0 g 0 G - -12.73 -18.999 Td [(2.)]TJ + -12.73 -19.076 Td [(2.)]TJ 0 g 0 G - [-500(Denoting)-283(b)28(y)]TJ/F11 9.9626 Tf 68.601 0 Td [(dat)]TJ/F10 6.9738 Tf 14.05 -1.495 Td [(i)]TJ/F8 9.9626 Tf 6.138 1.495 Td [(the)-283(v)55(alue)-283(of)-283(the)-283(v)55(ariable)]TJ/F11 9.9626 Tf 106.29 0 Td [(dat)]TJ/F8 9.9626 Tf 16.87 0 Td [(on)-283(pro)-28(cess)]TJ/F11 9.9626 Tf 47.57 0 Td [(i)]TJ/F8 9.9626 Tf 3.432 0 Td [(,)-293(the)-283(output)]TJ/F11 9.9626 Tf 54.503 0 Td [(r)-28(es)]TJ/F8 9.9626 Tf -304.724 -11.956 Td [(is)-333(equiv)55(alen)28(t)-333(to)-334(the)-333(computation)-333(of)]TJ/F11 9.9626 Tf 122.071 -25.714 Td [(r)-28(es)]TJ/F8 9.9626 Tf 16.847 0 Td [(=)]TJ/F1 9.9626 Tf 10.516 14.335 Td [(s)]TJ + [-500(Denoting)-283(b)28(y)]TJ/F11 9.9626 Tf 68.601 0 Td [(dat)]TJ/F10 6.9738 Tf 14.05 -1.494 Td [(i)]TJ/F8 9.9626 Tf 6.138 1.494 Td [(the)-283(v)55(alue)-283(of)-283(the)-283(v)55(ariable)]TJ/F11 9.9626 Tf 106.29 0 Td [(dat)]TJ/F8 9.9626 Tf 16.87 0 Td [(on)-283(pro)-28(cess)]TJ/F11 9.9626 Tf 47.57 0 Td [(i)]TJ/F8 9.9626 Tf 3.432 0 Td [(,)-293(the)-283(output)]TJ/F11 9.9626 Tf 54.503 0 Td [(r)-28(es)]TJ/F8 9.9626 Tf -304.724 -11.955 Td [(is)-333(equiv)55(alen)28(t)-333(to)-334(the)-333(computation)-333(of)]TJ/F11 9.9626 Tf 122.071 -25.904 Td [(r)-28(es)]TJ/F8 9.9626 Tf 16.847 0 Td [(=)]TJ/F1 9.9626 Tf 10.516 14.335 Td [(s)]TJ ET q -1 0 0 1 284.199 204.589 cm +1 0 0 1 284.199 203.069 cm []0 d 0 J 0.398 w 0 0 m 34.569 0 l S Q BT -/F1 9.9626 Tf 284.199 199.519 Td [(X)]TJ/F10 6.9738 Tf 5.786 -21.219 Td [(i)]TJ/F11 9.9626 Tf 10.265 11.754 Td [(dat)]TJ/F7 6.9738 Tf 14.049 3.432 Td [(2)]TJ/F10 6.9738 Tf 0 -6.209 Td [(i)]TJ/F11 9.9626 Tf 4.469 2.777 Td [(;)]TJ/F8 9.9626 Tf -193.966 -30.717 Td [(with)-333(care)-334(tak)28(en)-333(to)-334(a)28(v)28(oid)-333(unnecessary)-334(o)28(v)28(er\015o)28(w.)]TJ +/F1 9.9626 Tf 284.199 197.999 Td [(X)]TJ/F10 6.9738 Tf 5.786 -21.219 Td [(i)]TJ/F11 9.9626 Tf 10.265 11.755 Td [(dat)]TJ/F7 6.9738 Tf 14.049 3.431 Td [(2)]TJ/F10 6.9738 Tf 0 -6.208 Td [(i)]TJ/F11 9.9626 Tf 4.469 2.777 Td [(;)]TJ/F8 9.9626 Tf -193.966 -30.908 Td [(with)-333(care)-334(tak)28(en)-333(to)-334(a)28(v)28(oid)-333(unnecessary)-334(o)28(v)28(er\015o)28(w.)]TJ 0 g 0 G - -12.73 -19 Td [(3.)]TJ + -12.73 -19.075 Td [(3.)]TJ 0 g 0 G - [-500(The)]TJ/F30 9.9626 Tf 32.469 0 Td [(dat)]TJ/F8 9.9626 Tf 18.273 0 Td [(argumen)28(t)-259(is)-259(b)-28(oth)-259(input)-259(and)-259(output,)-274(and)-259(its)-259(v)55(alue)-259(ma)28(y)-259(b)-28(e)-259(c)28(hanged)]TJ -38.012 -11.955 Td [(ev)28(en)-334(on)-333(pro)-28(cesses)-333(di\013eren)28(t)-334(from)-333(the)-333(\014nal)-334(result)-333(destination.)]TJ + [-500(The)]TJ/F30 9.9626 Tf 32.469 0 Td [(dat)]TJ/F8 9.9626 Tf 18.273 0 Td [(argumen)28(t)-259(is)-259(b)-28(oth)-259(input)-259(and)-259(output,)-274(and)-259(its)-259(v)55(alue)-259(ma)28(y)-259(b)-28(e)-259(c)28(hanged)]TJ -38.012 -11.956 Td [(ev)28(en)-334(on)-333(pro)-28(cesses)-333(di\013eren)28(t)-334(from)-333(the)-333(\014nal)-334(result)-333(destination.)]TJ 0 g 0 G - 139.477 -37.944 Td [(117)]TJ + 139.477 -36.158 Td [(117)]TJ 0 g 0 G ET @@ -20274,7 +20278,7 @@ endobj /Type /ObjStm /N 100 /First 967 -/Length 9161 +/Length 9159 >> stream 405 0 1558 58 1559 116 1554 175 1562 307 1564 425 409 483 1565 540 1566 598 1567 656 @@ -20283,10 +20287,10 @@ stream 1585 2467 1590 2573 1592 2691 433 2749 1589 2806 1594 2938 1596 3056 437 3115 1597 3173 1598 3232 1593 3291 1600 3423 1602 3541 441 3599 1603 3656 1604 3714 1599 3772 1606 3904 1608 4022 445 4081 1609 4139 1610 4198 1605 4257 1612 4389 1614 4507 449 4565 1615 4622 1616 4680 1611 4738 1619 4870 -1621 4988 453 5047 1622 5105 1623 5164 1618 5223 1625 5355 1627 5473 457 5531 1628 5588 1629 5646 -1631 5704 1624 5762 1633 5932 1635 6050 461 6109 1636 6167 1632 6225 1638 6357 1640 6475 465 6533 -1641 6590 1637 6647 1645 6779 1642 6927 1643 7072 1647 7219 469 7278 1644 7336 1651 7429 1653 7547 -1654 7605 1655 7664 1657 7723 1658 7782 1659 7841 1660 7900 1661 7959 1662 8017 1663 8076 1664 8135 +1621 4988 453 5047 1622 5105 1623 5164 1618 5223 1625 5355 1627 5473 457 5531 1628 5588 1629 5645 +1631 5703 1624 5760 1633 5930 1635 6048 461 6107 1636 6165 1632 6223 1638 6355 1640 6473 465 6531 +1641 6588 1637 6645 1645 6777 1642 6925 1643 7070 1647 7217 469 7276 1644 7334 1651 7427 1653 7545 +1654 7603 1655 7662 1657 7721 1658 7780 1659 7839 1660 7898 1661 7957 1662 8015 1663 8074 1664 8133 % 405 0 obj << /D [1555 0 R /XYZ 150.705 720.077 null] @@ -20626,15 +20630,15 @@ stream >> % 1628 0 obj << -/D [1625 0 R /XYZ 99.895 274.156 null] +/D [1625 0 R /XYZ 99.895 272.94 null] >> % 1629 0 obj << -/D [1625 0 R /XYZ 99.895 241.264 null] +/D [1625 0 R /XYZ 99.895 239.973 null] >> % 1631 0 obj << -/D [1625 0 R /XYZ 99.895 153.877 null] +/D [1625 0 R /XYZ 99.895 152.13 null] >> % 1624 0 obj << @@ -23288,7 +23292,7 @@ stream 1811 4173 1812 4232 1813 4291 1814 4350 1807 4408 1820 4605 1806 4771 1816 4918 1817 5061 1818 5205 1822 5352 1819 5410 1825 5529 1823 5668 1827 5812 1824 5871 1829 5977 1831 6095 1832 6153 739 6211 1833 6268 790 6325 789 6382 745 6439 746 6496 762 6553 742 6610 743 6667 1834 6724 738 6782 -1835 6839 1828 6897 1838 6990 1840 7108 903 7167 777 7225 744 7283 741 7341 737 7399 740 7457 +1835 6839 1828 6897 1838 6990 1840 7108 902 7167 777 7225 744 7283 741 7341 737 7399 740 7457 1841 7515 1837 7574 1842 7667 1843 7712 1844 7851 1845 8038 1846 8532 1847 8861 1848 9204 1849 9333 1850 9354 1851 9860 1852 9905 1853 10595 1854 10923 1855 11004 1856 11379 1857 12016 1858 12675 1859 13298 % 1765 0 obj @@ -23712,7 +23716,7 @@ stream << /D [1838 0 R /XYZ 149.705 753.953 null] >> -% 903 0 obj +% 902 0 obj << /D [1838 0 R /XYZ 150.705 716.092 null] >> @@ -25843,10 +25847,10 @@ endstream endobj 1897 0 obj << -/Length1 2477 -/Length2 17492 +/Length1 2460 +/Length2 17290 /Length3 0 -/Length 19969 +/Length 19750 >> stream %!PS-AdobeFont-1.0: CMTT10 003.002 @@ -25866,7 +25870,7 @@ FontDirectory/CMTT10 known{/CMTT10 findfont dup/UniqueID known{dup 11 dict begin /FontType 1 def /FontMatrix [0.001 0 0 0.001 0 0 ]readonly def -/FontName /BGSLBR+CMTT10 def +/FontName /TJSMYH+CMTT10 def /FontBBox {-4 -233 537 696 }readonly def /PaintType 0 def /FontInfo 9 dict dup begin @@ -25926,7 +25930,6 @@ dup 107 /k put dup 108 /l put dup 109 /m put dup 110 /n put -dup 57 /nine put dup 111 /o put dup 49 /one put dup 112 /p put @@ -25980,50 +25983,54 @@ Qx ŠÊ"„¸Óªï©á“a¦x;ÏY Ž`³m ÷±ÎÆeòïï©"bsàiq>,ÄZnÊè›3æÂŒeÐÌ(¥±gÆØoû¦¼ =$ìRù·ÿŸµþܬú¯Ÿ'âJ:cjª3¦‚f2 N’µ:3CC;OÊv"<ȳA?9=¿Ô‡a’ÓÈ{úúMË»Š¶ö&}Lænu¦¥4ÛŸV[Ìà+.¢_…bê¨$tö«1ê.¶}ÉÖÇÓÁcÑü¯{ä«<<›vì÷ܸßÌzÖô‡<ú Íñ–ÈУÝ9ÌrÞµ"œb‚t¶™Ê˜$yéЪ֡Vì ]W–ÂÖÒÔ>£Ýã0žõP¤B’·W*ZCÉÆ›ŠOžêS€ ë0³é€Õaº‚ÎÖÀºåS„±5Ε÷-}7‰‚ÔÆÙ-Á›*¸IC®{1ȹ†AŠ˜ßZųä®rO‘(G n˜6ã¼¢9iã5ßbDýN÷²'wL å,²j"•éWv³yMÎbfv›¹¤ù&,Õ†H®†ƒѶ¼G[‚f…íÄ&“©PÀx¸´&Iš™ÿë¤i=(Ë— èz:‚[} š$êú>ÖÑ]´¡çIlv®yPôÙüdŒÓ[‚tºzÑwä;Ñhc¥9–¯éX S8ì{‘ÕY¬J4ks¹ð'$r+›tšý‡æ7)„)ßm&‹LWÌQÔ ãL7“)­³gö€·†×ó‘Í‘¶".ˆÀ¼ÿf ˆE›ý*â °MÊö‚:7¯õjm›˜ ª!µ'¦¿3¹xÄ<[r îä«ënÝ^™sºÉ:Ÿ^—M{Ã9E“Å·ÑÌ8ÑÝBãt<ÚW#ë³WsÛ 3’}Âæ~]ÏNAýÑx!¦ íf”ð%þÒ™ÄÇø°wÂÙ €ìˆëÃ˳,Ø¿QÖ㌴W싪ËŸ«D®t2ïó̉BŽ›°¸JD_æ£ 9b ʃ>,Šw©v­¯Ëà0ÍüV\åaµÙ4ŸT2G+¨óÿFä]ôÍ,Ùšå]©z ~aŒ1›æ›CÑÈãÓJU­Ús/ 'Ú«À±ÂìÅ“k‡¿[ÇM#I8ߦò’)¨´óq±U‹ë$ÔràCO>Å°½âŒtMÖý>úIóªŠV­Ì&¥õµ“€Mi`ªo k¾Öà ÊPìÅ^\ âm"¹eð¬]V¯D‘¶ÄÛ7uë\£»»~ò&øbÉìÀýOŽÄñ4˜ÃtÞ¡–KÛLôÔ¢”¸‡N\™-ÎvúaK’í¾D¹­~2W^€"á‰Ã¶¨ 8Y´JBX2UË[Ø0½låÂq°‚߃ýãÑ‹ˆ>â›ÒKHäÑà>sxÀ[bÜÿ§Ü¸÷ÝœYS«ú8–‚¹ kÅ)àöÃ!~¢w·öÅeÒÚmGäà "1™y¼­¬°Eïj^Á?5…ä‚m”H謥kØôC; Šíjc¹àº¢j%™(V«½qŒÕÙÌë½}óŸ‰<ü‹Ì9m·h>þæqóU’⌽"ýœHXù|yЄ’¬ãª><žòê%© -Ÿ˜‰»_2†æ”0Ój]yçWñ -ó>ÿ!ÙÔÄ‘rì,ÝQ?z⺑{@Ù$í…dâÀôÞ}*ÙÊE§J%GÙÛ ×)>­]6—ù¹÷t_ÜoK§ÐXBè½i§ºÐþN·9Ž¶T¥HOh}/99ÄçeéÅt¤sF¶|IìPq^‡ â¤Ï¨þêÐÓ›‚ø-­ÇfWÀîzžlìsÇ‚}–Ë/Q­ -ñ*=?áá¥ñ(m¹¦XÄiJj~†¹E§=*tÇeÐƘ!Ö7sàN•~Ìu ´9”#Âs ÌmAǃ 7Rà±a®yIB­uÏRÄ6Ë«Š{‹.z/xÞ"/oÕkýEßUw˜Éà5,ꯡàª÷ã|‹ÌÑ>d¥‚,ãwky ˆŽîJ‚d-0ö·â<äÐ:Œ'^-ÜD®: ;vn„Å›™ù.ñäp§ óê~AþÊì]±x 1y=ÃXŠ—œ“;Bën ›=D»þ¸#&J“TW òÓçߢTVET :@Á •ÿÿá:•)ô ÖÍ\Ê®vC¤@úÀŽjhXÔÉy~A·*óH}ìw™¯4lÛÜu‰Ê.’ß–øÊ™#2©rAO4óøS"Ø×ïéb—.ðnë›ÍµË,MiúÐU~ ~@TîØJ麜‡q"q„ìâÖ$ ¥î÷@jM¿ÛTºn[©‚ ‚ÏÊÁŒd¼J±Á„&Øê ò¥F¾mÑÕAEBôcò - -¨ ɹ)ßµ^ÅÊ>ÇS&Ž(Åq¹RÿÚ¨[ȹùmhÚ˜¹¿„²q_~_ÎÜ¥¨b±'cXC9íWÕ˜èz±!xmp¢i‘3jà0AH1˼D\K’Âòe¤»}ÿ&C¼kE:(1ÏrJ«fË…/3yñǺ¯›V:‰ª-Þª·“a®æÐõT˜ðRÀpï.©Úóev>IJárpô:½HÜÓCpwðr«ìIÈ»„×_!„Ç%>m(=A°“uhAðç9ôƒ)å~YWøö ^f©±Ôκîä»—©a/ÁÐÞÞY6BNÀŸê.„©®f{áÂ{H pDuf^ÿbÜi8û Gÿw•ÎxüúÈ— ¾ ·¼é,¡Hi © -M2C“ÉÎL™)Åy.ù)qõð¢?ÏÀ.Ø=û­L©ìN¶ÿè"»ü¯Ã=&g«þÕŽ–ñêÝ»,ðÝ©×CÄTß¿•¢ÐEºîâfôJë—/ž„7¼Ü¾À·øafÆé[=ãíN>OâIR&ÖÒ5)v}Ððȸê{ý åÆ–â‚ÉOlïKµýDüBD}û²VeNpü¢”læÿTœžæe–I'àÚ=´T±N:Èý-ÏŒp <‘ªQ€ŽCÍm‘ŒŒg2e†rožÊ\›«úÉ2³^Èz[jx  Žêu4³ì…Á¡¥Ç‘Àì¾ËÉýÏÞ·¯n^©¤yÒp\`V -¬‹†è°"699¸ê¿-p;ã‚1QÄ|íº®>ÇPúàÅÑáZ½¯à±ˆ^rƒy®ßL}Í ƒ¯Vè_Ÿ¼¤d·7ò ¹Îóh݃mâˈ= G¦K&=ûïšÍRu|2}¦`ÐîE8¦ Ä‡NHn`7³ÛÏ•Z¡Yúší}ÖŽo/Ñ@uäa_­­8÷lzÌ棘ÃËOn{[k;a&Y(ßI¤ ¿ ‰ðͤ#Ó]+Ñ rIÉSk£Ñ¢u)uçb<ÞðÏoÇ[J«Cm«_2Ñcc¥YEïe”æ2û.¼ ÝþeKšœ©± 2íçZ†IO˜¨2Š-šò½/(Ñ=3ˆÝé®!¯å¿KŠÐ¡ãÒÞœT˜DLJ¶©S>cÎ%øyBjë ã‹ž6Ï¡Ò\¦›YRKÃݽØLýpþvaÝõ¹Ó‘î,•…ÊÛùÞÝ ¥³žýãŠ}=2m¸­ÙeF£ÑÛxÁj=™/kKç–oÜ“ŒÊ0Ô(TCgg´ÐùTiƒT…œæRî+õÄc"¤P©O| ÖýNŸ;ðjÕ¬†¹Yb˜~nû=Ò¯m<É - ^[Uà¹ÐBÞ MHÓi£q -W Dà©®3öwÁ+»TÂCÊ àH“•lÝÝâUæe…v|³gÅ¥l3ŽÕýVœêD½ ™=ZBlÊÛ¥ìüŒõ/Ú•I|Üèõ‚m´‘…ZàÅ=™ºûÞ0>ŽCÛúå”@!µd.7 Ÿ»oo‹ù=•Øá­>ѵ8çÁ\&ty‹k‹Ê¿ef«‹%hÚPQð=š¢‘£îÒ$òa÷&uÓÃÎbZý›‰Œ§¿ì8b{øe|IoK(î¾!{*^¾Sñwf0TÛNà“s0W±aôNÙÜQŽÕ-úô¯‚’„¢³‰oí«åê…:kÎù'k‘˜—)–Â$¾. -m»jn@se ´‘Ó\[ø¹ÈðyHd¾›Ì¿•û¾V^Ðnì8' „‰j\î½Í=EøBûù&P÷ÆP5‰.6¯3ýO´ËËè}œä<.»-ôÌ:>^ 2Ý1ñA“Œ lg^Üý–˜øˆîÒï>äxA¢šX¿®ÃÓÇzPßÈLªQ°,"5]Œ¶7kY{TKn$‚ˆ&Hµ ^$½Õm2U£MÆãÇ%€¡®§o«²jP,„Ó\¢½^D[V‰,¸º8¢»•&¡Þ…ñé!a”kì+ÎÖP™*Ñ&)©Ü ž½^ »¢tËáÇ d|ž‹4í7ˆÏÈK-W³·£ò©èér;G¾Ñ\`>M&Ë-ú_7ÏðÊÒ@Æ™cä{ #ii¬†Šx út’½ žÁ{ýBØiàﲬ¹w2¦\wùÆ!œþ¦µÓNíÍÐgšRkë_\ é\¿Ó i%¨ö&@àÉ°]~inˆÎ"ÃÕ¥öÖ¥÷È<¸ Î8n¼¨þýÖ Q>Gä‰îF¿3^‡4Ù…Œ<6fd[eñí¼”5þ¤æ…˜m ]Eu‚Á_Œä÷‹…øÄ9×}Àe²:ТR,ò¦ûaŠ\¨èÁäüEhÜ]'^ÑS©7Ô²KÒ¹ûb‹_è¯ÍRµÚ…lã,P,e¯yÆHבÞ=Ú.¹=lÅ»²ãþ|°ˆið†D==h•p¶Š“†Áß u/É|‰ì©ÞÙOØ[ÿµ æ‘P¨f*Vð¬Cìˆë±–ÄÌÞ0´ê­®/•z6ÉRœOˆ»òØbØC -i­èñ‘Uáx¿CHÌGdRÝ}Îþ·ôÒ® »°„e*â²¹äJ,Tï¡Á樆h2}\8XÞ—f—swfîP$N²Œ5V§t<œç¬Wu,¦¥‹í/53U;ý÷3 -QsgMö¥ró1Q® ö›c«¼Â›”©FEO‘gF˜¿F*q ÷[ÃHŸ½‹ú#™ø”/€þ lµN'Â߆:ÿ­Jò…T™¢ˆU®Ñ 2ÆÁ&@àÊyánAV-i˜©û(ÓIn âMDH›d™ðœNH2'ˆ§˜¹-üæ'Xæ?Ó](IÖÔ$pž‘âøkÇ„äê]RÙCíÀ;¼¿¯nhN0á7*5VÆKhZ] Ãíœæ mòØ ®¬%9æøÀ }f·’k$ÉR´öí¦±?ÆcHÓ;zr<]j¹¬3Ðù¬zfñÖu]Zo”íƒòߎö£àé®,÷a×#¹šîÁEÆ# - êg}ßÍ(h¼Q8âRD„®{“·wrt®Ü)pŠ¥Å8,¨q¦#Ø/–8¢vC€WY •{ÐyKe -žÚ¾¯„L¹aw÷$ç C:Pšà b³²s'ØWýG{¥0×j3‹Ü {3È…aE¾÷Ù½P6hÆâö¿V¦Ciû"Úï£Òe«3¼'‹\†¬¶ÂX¯þ4ÑmíŸÀÿ?õŠÌìÚ£¦ëg„²ÙåW“‹{$5 ƒW(¯RµÆëAXy¼¤ ÇhÕS^šûxɺ¿!RÿNG“Šã*5­ôÁæéÖVp9nÔ=âŒ,Rùàû˜®¿ßŽü¸­ÏUsIŠh¾#•ç@ï]Cz}ÖúIx÷z(gk[Q”D4›Œ†ëJ6qX„¶Ëºç!IF@NÖ«EøG#sŽ”Ã!;G'?y§t›ŸÍ.1ô^¿·H -´‹.©ëXÐæ?_Ž,ÆT€èX-Ñi:M‹…¦u–€Ñ£þ¤ùäŽû“da3}2H|šd=7þ°`iHT;ѦT™˜¸ç¹Ù¯¶¸“c4>´4bÈGÕ¯KjßÜ߆œâÚ^\qÊ&Ü,]Þ‰ŸÄS2QåACtÕC¡QU\›Q8ÍHZå!ÚÿÀóÀ“Æš7 –ŠL ¹I$}‚^õÞÐ:ƒSпZ¶û¹+·¹¤V’ ÚtT¹÷v†:{ÀÆ0˜5øN^4Èñ4˜Ž+7FèMÊÚ³|ëúRÛ!BiKW×hZA 2ÖÌÔ}þÌÃHvsq™]-î |>‹.,(ïò—BŠêƒŽgœMñ™ÏÍý;gúáJµ<Î9l51€ž€Q°ŽÌÑl2ŠMçž 4ÝâX$Þ‘·‚ŠòO¨Ús|eîw”íÂЬÖÕ<9êcI‡ÜÁ¦ó¶ŽÞ¢@Ž–[º8Mö¡=<ã[>§±iY˜Ž$X‡"Ú½×¼0øMÈÐÜÝWè”R_é„oÞÍA#Éß\‰ž½GyŒY…¹˜Í?fC-|¢Žµ!ï9IÖ>g…< ~Áˆ²¥-¶û?UÁZ´‚ŽíÞó-$V>µèæ3ç—Ät ïµ7|0ÖÙ×"^ˆk»­ç— -#HŠ:æh/GP¯X%„çmEöácß_O¹õ9‡Ÿ¦ØcœîÌÜz.Hj+½–l,LácŸ‹ò¡ÿNñìEûΪۮªZ¦8"Sq$—üÒ§»ŒLËŽÙKØÚæx,Mä/Òô²ý›ŽY]îØìgF%á-E¸L.á¸õ4…-€6bÛÀØ#ïïÀ)m´D8á@\kÞN†ºŸ‡/;v˜t1ã`ªmºùg—êxtLAëJ€ƒ‡m㪠¥Ý’ ìkŽ¡ÕêÃMŸ…þ!_0ètO†ßq¬rNÍ–œÛ‡/FxŸ·È`Ó¸D7Îúü`\蜬½×JPr)õ -L¢ØõU³žŸLÂs–Æ·u¢´í¨ -N!3<*änµC¸žçr¹2 -¶PX˜10q“mvjÒEÄ(ù þ(Ù‚PµH\-[ʆ„¬÷´iGÂ*ñpRʱ§yz ¨y:‹Ù½Ž»¨^• Ùܺ"»•.R•Áæ÷Á—"îßNTG¢4sê¿‚‡ÞѳÑÏø–J½ªÞR<Ó\X \„£+ÄŽKX{`5ß´˜|Jœâ†Å§ÐÛ-÷1š¸â¡êd¦ùW}щšY¿_ì‹ÑVzš»hXõ¸ù¨Š/ƒÃ1gcïO¯]wDyGbœó€¹Gã|%§Yw)Š}åľÏÂÓ²(Ÿ):†LÇ3_Æ}SêmT5ÊöëÁ‚‘(ªïþAú$ ƒâÕ̹}êcà}(·ô5=…\‹ìƒ*€¦µÓI#¡›CÎsõŽèm§N5Øo¤Nj.£š 1>`í©Êši¹oô€ªäz!Å=Ä®É>È®¨¤(q9N“Ö"Æé<8ýÜâì ‰4±fT•ºtèò¯ŒûØ)FCðµsÜŒÖdE8h›ŽÀ‹ü,bµIzŒª9‰50|™÷Kð -l~_Âà¯Kózd¹­©*ŒE–«Ó^(/™(_×9ÃG5v­÷]›¶ú2Ïe}öˆí¥æJПS(‰VÕDp+X” ™bmûŽy²±ù%O Èœs’CO¸ÆáÀ6*Ôžüõ R³Vz” uýÁsþ1‰žâÊTËVUëd4._¶M‰Ç¢ñ?¢Ÿ¯óbŒôëã²ý$;} º˜B4UM|DÀdÒÛŸLŠjÜ–/ ¯G&àÕ¨ è÷÷{ͳԛ(¾!|cƒaôa¶ÔPâ 7Iœ ubÀº`Û Åϲþ(ØÆÕÜþ·’G§0}vÚgµ1ч¸(%1)ˆ`þéb r„±š+]dÖ}ƒÓ~=TXƒ0ÂFK½VZ)Ypñâ‡:@Η ʊ]}Zã‹~‹à“ì/û¯m+½Ðƒ­Žù7Çþ¥¿ÞWäpŸêæ$W`Å×0í¶/?‰!é"E¹V9»ä„÷ð„ß‚à}Ñø¼t‡öêÆ ‚êz wÌm¦ñÝô~Æ®g0‹¡…z¿Ð À°ÿ³Šàx¾EÜbÜÿRÙíí‘…8‰³ š“¹ô+^/¨ êÝ$&-€¡Ý¡9ÅG ¶Ð©mgسèü€žû‹}.1UŠ,´å+Ov{Úôú: Òæ2c’ÕrÅ„ÊäšG¤÷*.Q!·×Â}ôì\U^®®·Ý'cO6âç'¾Pt4ëù=Õ79‰®Dò@[€D¢Ž@C¤ê ´XÜçYDF*ËqÝÞ› ½ßà=¾à”f¡³v¨5þžÏŽkÁß³€¿É÷*éÔ<¢; ÕdÇ´y”#†¦Î, «‰2•æ^l8Ä@ÒóHh£3Y£qóD®/$N{ârÿú½w´bK*µæú”yEæGƒ,ó¿ëº9>Þ–F²Ù× -‡‚£0ò /€"=߹ʲÏtª)Í –OT ·5‹/þ÷%y(|«Àº‡õ×^]À‰ù˜ìÏMî/ùŸŠÊ/½ß¾h¤ºÙ4V,þ¸B Ç•íjà ̲( _›ž Â+µùA¡Äî”Ý·%Åé ÿ/ÖÎܾÊ8÷úBrSÐ즼‚EMʹp0„uxZ#¯R -(•Ï¿¨#á‡å#ÚÝÈ¿ÉåÿÎ@¢nH]2Ž\-øÏ0Ÿw%tƒë]äz|D÷ -a¨†*áül 5úE´‘‰¨ë+[S9nWÍ<~÷¨·jÂ×eµõèn^ßÕÔS]wáò±v¤+g¿^üÜO©´ÈTPR…™'˜1™„!’ˆÓà;Ö;FH»SYƒÜtÂÞšcòÛq ñ %h~y¬íòSÀŽÅ0lm]Å–K~@9Ó0ÿ¶Å—÷ ]:î9îh.e4;ÔÖCŽˆ -ÖÖ`ýºÄµ¥ûÄÑ%]’*XNÝêlp†2g|Ÿªá ˆ Ä•°ÛHBH‹®®' Uó Ø]±&õ"d; Yué2G¢(ÉÇÕdÚ\¯û÷™ùA7nØK—T“ü“ü†rðyì‚BÖ7»ó.èÈÃè”Öœ»¸ÛÖƒïzªzÐÞw¤ð)dÝê_G˜¿úŸEe!-kâê–ÓÁÓ§nÚH‰cCñ4tzä Ø ÇÏ‚ªuÁ;é@}¢À‚=„fe@Ì-O;§Ô¤ûñÎx¯KÆýTÚÃø•@ fâµ£Š·¢€áüàøÃÏ^-ŒEÒŽ¡ÑS²Lšççû:8Öðdû“-€Å -àéÀ¬$yñPÖiGª–8Ù‰(;X'§½ÿÛQïù‹«Ø\Ó§=ë—Û!)ÁVJh²¡™ù}–u»w참¥=‰/ÍìÓlAl±;LÉw€cU®„DÞXü8‹@­lŠÌ¦å5¾ºQ#Å úãE4|1ð¯/×\Õmƒ9üÜ,Íý1 ; íÐÀì7ü§Åý:áBÑïU‡d–mˆZÍ%bÇÈp‹,eQtÌÛËœÞ`ÔCÇÝ´èø© z%-–¬'ÿ.<:/å3Ó÷˜‡ÿÇŽŸ:»~ËîoúÈï¼HMÞ{½ÒaPUO~KÎR@/¾˜Úu¬ÛH“ân8vòÝA‹¬M:~sØær Ò›G„|qÎ ãüÒš -Ù¨0W2^—a¾ŒÌ/ù㣦_,Ì\ yˆðù‡G8+á·‰„,Ûbgã¯Î® Gpä Gé䎦♞»0pÎZ`vZ -l#[Ü×tZ­Þ›7 À_úPeàT*(¦k -£aãï?:H|oßʇ|Y£(:ë+¯§qöÁÿ,…¿fx÷€>N‹Z0½ür­¯M_‹ -œ -‹ÜÒkúˆ\¬ÉÀ<2Á'?5“ꈌ ·Ò¬uÈà¸Ý2uX‰{à1jÜO-ÄÈ:¿å†NªÛRž‹•½Y‚«uO.É·XÈ–½,ãx[]KR¸—sÄ‚•üfABÅp  þz1Ÿ6A¢¡Ø@k5ÖC=½"ý¥Ã–5»y»\è7ת76ß&ĸy§t8KÏ KZ%7ÍÃuN T%6NyÆ4wæ«Ãct|Í4ª8õš‘ýTbútÿL{çpkÕŸqâ ‘ñù\hôþȾRdÝç±IKØhußk;ÿ+c -‰Îü»¿û‹›l;E¾÷<)\5gËnaIç~rhYÂ1ÚSFÎy XØá N7´„lnùy›/Ä°Íxà£HÏ„¹¿Õ–ï#£…¯Ù êÞȵy¾(^§¦†Ç1ŸB<º;%nN0 žñZø+ßgô h:’1‘!È^À‰÷º¤Ü¦ÍiHdFv…jÎ’^ýÝ!ý÷[Œ=£{ѯCqãVû¶3ä[Ö¯> ƒõ€Ç[.)-ƒwƒ~ÕC?¹¾¼\Ó+_—a! Gþ~DÛÍ­¯gR5íÐ?YÍ/tš÷¿cláûv£†ñ -·_Žd¢§Õf’§J2¹ bSDÍñX·àm¢X\EvöïDËûYzV>!BMà—‰)lI÷Å ”¹ÒáWº[”âQ°ù,*H˜M<6© §U2é¤g­ì»Ùlc›Ù­]¾kr;Ý+¾7fdø"ªbà8üäµA›Úôq-!Ç’¿Æ>É‹É!=ô I“ÌDÙ²è Xµ&æGt»9R¿¤T‡:KxÐÛ!¦îÇ“ænØÑ:UFÚ;Òk/¸£_dµSï$œ8aÒ†|ѤÏZèܪn¬ -[¡`ÌÁt¼Yr ÷®'‰ø{ukXÎs~¡(ÉO?pRåè‹Ž2úœÕܴУcrXß+¨2fŒD@ªwó¼BÇ<„Y#r ´¢À‹O=¶ Q‡%ïªe´©Pø‰x;à²Ã†+æÜõÿA&î‘mÜO(xˆ†·OVÒ®¹bOç,õˆ¼Ö]p¼à"þËtͪÿÍãÖ9øŒT/ÐR:«·==„ÆfuËà€Ø¾Tñš˜„ô‚<ýo]“;Ô&UWeMS1‡u‚â²Ö<-GÄ+–YOL%†±Ê\A èÅÑH¯î -²ƒiú9o¸<Í(&¹=\T_FûÉeÍtèŠYö·hÌWó«¨ÄiEéKzÞ 5r¹ÅÀĹM™GA«€¾Š§Èz –¦J²Ð×,®ž¡YþóÕúQÉbUpæñNiKÆuØà5!šHíüY”ª]Û€ú©ÿ­ˆåM+›1ÒÀcfÍz%ï'/ì³>ÐPî…UU徕ÖùE¥Nœ1@·l¦/t®Ú×­ÿεŠéÿXcœûXWþ*êìÄf_©ÓÚ¶Ý6ÓhNÕl2¶;þþn_¡ÐTˆ¼UPŽG ÝEZBöj4óÃ.ך%¼¾3µŸP%ß.ùˆï -,ÁžDƒù' øzz œ|ûàsP±TOzs3e]£1}ÒªùßAn5° -]õÍ/ªŸäŽ°¹¥ˆwqƒþ¢LT ÙÌIkb‰y9¬KPo›nô6Aò7Ðñ)¥¾r~‡» •`³bôzèÒ-óÃ)àE$½[Ó@ÊáÉé> ZÇI“w=•â°œ_xFÔ‹ìä›kvyBbÛµðȈ[¼WÞxí“ã"kæ£Io|f4N´¯&vHx²eQnÅ“:*_ž¹†ÌÞúù™\Ãcõxň2biý [àB¥ßU½¦#A ,0øQa‚ÂË;Zc-d§JÙp¸d)›½§xõóžãB3}P6òú¡LJL6-+¡Aí<úa÷<¸6ÖŽÅjvû‚¸N•é£ëg)táÀ@óÎy °ì¥N.ÈÒu¾GÚŽø9& -fÝÒ›‰«ÖÛ-¨WÖ¬APÂ4veŸ¸.%êTÈ‘šŽucçFÛw®Š³žô_dœ˜ý˜ÐµPûŒµññº‘€ÞÜG‘¡6<ÙþÃrx "Ш&¹5NÈü¹,x§di­½û¢lÈ°ëH-âS|žêWÙËvW†¡üž%YÆ“hg¬¸¿²³Ênh° {ò2S¯œÜH샩v[äöø1À˜ÜBŽ¸ÌYˆVÆÐòf¦¯¼\ Úsn__jS:cò[;"•F·Ð¬£,Ã#ZGÐ72²êÕƒmÐOÇ3ü𬠬X¬«³céh±#a‰c Ô'(Ä2gi˜ðÌh=ÕÏónY^ ¹ÙÏ>™ŸY»ó‡•çz0„”ס¾ôåæ¿ÂìhDMï󴣤„‡lYè‹ X u!¶£$’äq ’´FÞuA(4úB ó{%iX&‚?¦-øSTdj(agÐ;¢ÑjT ·¨iï먎©Ô¤³ž ÅØN¡ –G`ç;†<8œšGJˆ9ÏäÃi+ǹWÁšôÏC ë°- >q¶q7Në©Lù¤/Úöb"´ÈüO,É\¡ÞãBüôß<*O­¶µ«Ú7ù옊ä^Miõ¸qÒNÝy>z¢tHÀ×FGa9à€2”ð}ë“¥…B˜N% µ“n¬â:WnGO]¼:êÔÜRÐ>ìÀ¢¼ìº6ÂM€¼[6Î,ϳŽqšÜ{œ½¦iûâ+Õ‰/¾D‡E°5Œ@ï² "¬×ÁP°Äûå ½câºåbD¿‚´ój/¦<w5&É}ñóùWù7‰?¾E«Y¼Qf°nzÞ quú±£ &­]U®ëÝÙïo£kª¾‡­€óüÿÖ 6|CúDg= ·”Hꑤˆ+F‰ø_@R}†Þ cf™øARŒ‚®@¾„OɆf«ú4r× -êCž&ÅPVð‰Ö´k™/‹|{Ä&‰Ð}/6s¿ü4g?™ÏÄ-0b²Åf•§êåðŽ[€F%Ñv™¸E€ÞΆZ–UEŸfCöäÐüŠµŒƒ–(œÌ·`ôPj¶m¹TSw—$v˜•,ú6Q5/×Y¡i zÍ÷iìKz–{Q`+qëü€uàê¾Â F|YŠW Zt¨#­;ú!‘ü¢lÃäª~1ó‘bzÿ¤·L^EAbDKB÷bÕ@Œ] ø$T?mv¤rý.o|ùò1‘’ÂϹW9$ØýnÒð¥Ã¢º@ðÒYÿAxÍÁMFˆYT‰­Aâ94LqsWä'“?­{¢¶æÔ¾‚¿«š·äŸŒI$¥èH&êb®ùNAa¢/ ãqÚÿ,:7yþ½¤Fé’ºdð£%-m[Š,)¾áÆ«Ÿš2#°47ëa.oÃÜõ"FüÊ¡®Kµù+c Ïayõ,ûeŠ™›ƒ'¾ãñlÈx£ -CýEû%Ù=£ÊòÁ¸1ı[Íîd†ÉWGc³pÚRÆû-µHëDZKcar¥®¸\½Ÿ’&ܱM†Ø3XÝW ʼn °&ºÉ´³xD¦-H€iÃ?Ÿ„\u÷áÓìêë¦õ:$®CNûÓ8ìik—´hlHåMåÔ(4+ùFÓ½˜T'×uÝò® ðlçöÊ«?—oØŠ3ËqWŽù2ƒm¾ÿnÄbAv£ÉÛR9Ú¦´lq*pSÇ:— eÑWèÐvüý]÷sxÃöÈØö,6ÐÚ[Îb˜ÒîíÒBù6¼§F§¤}ßØÂÜû®áGLýÌ¡Bì9f Îû*=ŒpêwýK1l7¨óN…7å¨mà¿gVòu¼Go7ëN2ÉL„Ö‡nvãƒÂÛ!_ú¯&™¤}"!jÏsF¿ÊÚžoHŸh’5ËÚ÷d“hc©þôéì D¦ñVULÍÏs»-þ‚"áú~ßV˜¤©¹¹ÇCqS•.Õs:8^`’y*”3|³Uˆ”ç -€§wõŽA†+Æ^-ë ‰Ô>¹”~ Ä™qµà8œ6h§¦ã¥¦À°‹‡©[HW:†®ÒC²ŠÈño½§ ò*ÕzC×kÑ3 *,¿y4Ù¤úÇNA „ïjôIC«Ð}¤«‹¾Â!ã2^cöÆ¢¾ú0¦˜Ð†G^ESvªW'GŒÞ#ÁÝ{Ç_èµ€x óCJ Zj®]Žp‰˜Œ—¢eO°A¸#ÙÇÚ¢wB¨÷ -8~¯ -öÑhD²cJ8· <Ý‚g¹rôx³Œ!# ™¾ t¾ZÉ0¸âЫ4´á‹œ™¤)}=9) =íð¿—(šð<¹Ô_kMQðGíÎÚcÃ<,å«ò˜‡û%)-x¶ eÅHðÈr/²€?éÒîlk #É»ð¼9¾v’ЮÛ0¥•š_Ï@«~)”ñ{%"z^Ô)kÃ¥„aŠ]¬ï¿àF„Hæ}ôpVÏ8\AÉ4„{` Њf­(n„*_æüUÁ:ôxJoØ%ák†'ZøÖ¦¾¸¦šr£SÊCkW)«3Ð Ó˜^³iFZÎ5¹#C;².4¼¡Ø¥+²ç°œjú¤¾=ûûº¦¼ÿá›Y:‰-f´—iÈaùèߪMÄÈ"<¿]ŽÚ^,++G³Qn›‡3¸ü—¢mäôT{õñ=ƒþÒE“óÏðXHÞ`óÝÿ»¼¤ +Qš=>´óq±U‹ë$ÔràCO>Å°½âŒtMÖý>úIóªŠV­Ì&¥õµ“€Mi`ªo k¾Öà ÊPìÅ^\ âm"¹eð¬]V¯D‘¶ÄÛ7uë\£»»~ò&øbÉìÀýOŽÄñ4˜ÃtÞ¡–KÛLôÔ¢”¸‡N\™-ÎvúaK’í¾D¹­~2W^€"á‰Ã¶¨ 8Y´JBX2UË[Ø0½låÂq°‚߃ýãÑ‹ˆ>â›ÒKHäÑà>sxÀ[bÜÿ§Û%ðº4ê…›ù‘Ð5Kʹ}£®97‹ÒïB…Åôðú~Ú§àš_'n"úD|¤TS³Ø~[£ƒ;o£¾ù(ÂO8l¶“WäöJ(¡HþÇÖk¼³"ü^W±-etVc£`Áz½æ»ú2_ïöþ](:˜7ÚŽŸî_E%$Ãëç!µ99ü +^DlE² ŽÚµ8 ¿aróx| 1?²peW5¶ˆ}ƒ’2ÃOnƒïêP +"hó·åï—/KU%ÅKü­ˆ~0[°ø— ‘P`CU¤/×ËÝãݘê²M3ʽïæ„Ëu²ÅíÇ‚&gk7XìñžpËïMÇŸîî²AÇÆ{C%u‡–·‹Ñ%ÖÛ©|ÌV#GÀLߊb{%O¡Y3]øZa_W!¯l?÷víyf£*8ê*ã¯l4]­ù“¡e> zfÖ(½ìãY¡æ€`Û˜šóõ8?‚ÖH©PÙ‰’J¸'.§dÚ°£Ñ?¨X¼¶¬ð¤„³û·ß*y!Õv4ý†8ÌIv 1²Lnÿá€÷?hF,CO +Ã2fn_Z™É,HcO†ëƒ¹ÚnÒ§cHÓ;›«¯ýô¥ n7ZB™žM‘]Þ%“Ç–6v &ó<¹Ë‹9Ý–ºÇ†x}-–`{yq.*Za}ðôŒBu’b}Ú§a­ÆÆ“šÎNh¹ Î\ÈëWKÅñè#”aBöÛ³ä;yâROFË©^2ÌX1 <Ä)4ÙmT¿UûþÀ—dÕ¨4“ ȵ•À²©ªâc3þ…P1ØO\'(Ž£L¸?Ž×õ„á]J€{Ë||-UóƒOjk·Ì\|<³‡Jºùâu!I5Ÿ9Ù©Ûå_;MÛ™z>T÷ƒþ>K1ŸÝWî¤Æ^F:Ö¼R±6°‹§‘¦&beïˇM$/YýEêÔó±ó‘ÄüT¼­òR䙕æļx¹sÁþ¶pê¶ €…ú—þiÕÅëäPà/²ƒYý´La5{ K +Šyóæo,F'=ýžèCn‰¤ÄÜxl;`%mªwoðh`oƒ(Aê\•=Ð#ûTЇÊZÞ°×T6™ÔžÍPäH vçÉMcäãwVES"}”û£G“$6D¸£>£?¯…ªÃÖgx6O÷+ñ=’|«Ídñæ2ËŸ·ò„;•l˜¦„½ªõ  >¤Æ«“9Î…éÏÊ¥1”v§`ýÏTÛb˜]úŠ^Þ¬šjÏ-ýYOCº=镹jQò¸I÷‰Onu&œ$iV¨Js·Ð¹^8½„á!? +6.“D²’Ĉ>øL¹Sh¡ $À;äÉóã‡ËázQ¾Žþú¤´ +}§´A¼¼ŒÛì±,ÖR:Tôð¡ôc7²µÇq ø3«Š*Ø.ÎÉ<©èÀVõïUÜ5ÖÜ®ÉßËã£ö 8‹º ÓzЩbt¹pt$ì¬ý¶¢2{<­ÃÈMØÖ9*üëˆ.¢Ýnv€‡Ü•–/·_*Q‡Šy°Tæ/;Ù&Å”Í:‹m8DžÏõÜ 2·Œ(D´Óîk_kÌZòm]àͨAó_ôµ6E ×ãÕ¥JÂð&x»ÎŒƒé;­r'hô€ˆ"œËÀ`iÎ%©Ûo'Íb™Í¨ÐÛþ ª+ùÅ:ÿgß[×è-‘—Ú𞎣˜<«N +ðö’ƒEÕ¬ '©WL^éöšþ‘w=¬ÀpØÛ¾¨¦´ášÔ=•üÁ·¼’̾cù«‘•KGÓ+0%»Ó yd›Ý›á¦ØB\ŒöäíL)GÜè@ЗS¥W$g÷Ð+,â|‚€'Vµ§èš19I2’µ¦.פ›pŽÙº´rf—MXŽ±"2æX“¨ÉúÕ¢@ï‹uRïU˜¿óË•ÏÇþè•) +(!8÷êô5AÙwâ¹y͆'RaÚl¾-£áòÞØŸù¸ ½™Å­!ì4ÐÝÒ‘Á÷?pü†kÛJD n¼d.Þ¤¡ÃRP‚6N·¹2‰¾ÀJUnóŸXPû@›?—Ò‡G•—ú¸tZËÕúÒyö¿nwúAXߟ|]¡ûlôû;f¯ Z6µC“»ƒA'Òd„íóþë³cÌd÷Ñþ˜c´šÆßM»x5“ì`ª:ô£ÒH„Õ·¶àÏfËwAur:€ £æRf¥?¼avÒª¬W^mxj˜ªök¡SŸÈšÅU YªãÊ^û1¶Sp¬ÓÚCzVË›*Ç P§­æ#kÎ}Ù<-BðÈm,¨)*8Ûצߔ#ýø´¡x|ÝZYQê‹ö›õÄqßÖâ]@Û;óß–Êý^c±‹# +›À,âÔ«ÏdbMØÌVS#1¥Z|æñcýÔ:2¿ À®}Ôø¿qds ‡Aq!–€ÐÝŸó5H`®E¢p8º¾ç÷•ø³s_¸N_$6(Íjt”ѧw=9€U&0d7R^ 4`7W½É¾‰Ò'ß3‘ö ,}SgaRoð‘r·qZÏÈ6¥ø¢Úo£ +þ>DTîá2¦*˜KJõºwúnlR8všAZo`DLoô²k©}•äÉfÑ.w®¬iÒ а+üh†âùüß‚ÎÆI)uÑxsÙ¦@w•&¨Íø¥†Ú¿žØ¦Ð¶IÜ­}h +A®k(ˆœC1<BúOž$×Ý¿Œ‚°À&ª8 Ü9_LZX¿zÄ.Fì ~!TM‘z·™d¾ -Æ»†¢™x§¬^º‚wÏäžÜüSzw†AÆ)¾K9`QüƒŽ°^4›í¿[,.ø#MÊ&,¦ÈÇÁå3"_îšý;-‘SHHp¼FàÄ4ákÛCwTJZ×&Ê~þ>ï©nŠu +i1$mHL˜ó&X6|ü—Üå‚rH Ú:·‚Cå°ð.O®þ”€±5Êê6 œ‡"ஸû“¹Ryu(iàÇnê;÷¬27¹¯K€Q(€9‰Z«H¾ ˜½ÿÙÎÊkUi +f•çëÃ"ÈfM `üŒ3ޘʚ¨“K’Ëd€Õ|äY&Æ–’PúØhg?LZô Ø?f­|=YÐ r¶ô¬.›¹r¤B˜‡¹)ež$K"ò<2£³?8ÈAÑ«°c¯þðöcŽ½ÞÐܘ!îJl  ¸£r÷~tST±¥óÇí¿Lÿu'åMå\Aj§ˆ+Æ„iµ ¢5ášOôøG8„­—¤–g̃oÍô§^'‚‹.¯l añGËú7{59êعsK$ÐL?2{‹0T’lè¿°YÅ„~1ü«kÚ1{SkZ­¬X¶®™q—,Óòê²RŠmQÀ´¸ù:ƒ®gÛPˆT£®ŠŠSÉ{—¬*8€õW2ã‘ÎD¢]HŽ‚œ}é¿S£?ý«¬)içB‹†Vî5Ä·4Ö)ÎÀ–:Áø9W¢f…càs§;²‰*V®zJ©™A>”dv—r­hqÁ‚óX ®cbÞíÓó‘&¯÷‘ÎÕ:šjm›+¼ÔÀ[16dtW1ù˜NøêÄ«Ÿ}gNÓ´?öÜ'ŒÔÎÁR•ÇÕ„Û½dXlÐí÷N¾ÎnÄ')[î)ÔÞà<î_âÃ$ðLoyð²TŽ2îx ´ûŒºw ñ¦€Oo¨òÆ$Š‹]¨ùȾ;üF3«YïoÌ3‚µõ +Ì Ø"‰÷ð +?û[m¦ÎzlX- –Þ¿ÉRÎ…ø¨Ã ¬QMo=´ÏCm‘Çê`!1 +YUû…’–µÝ#AÑÅy™ŽU¼‰ÁýZvæõ8~ ú|ŒŠ˜3Ëçsìÿ&ˤ–åèJLnÕŸÇ–]?Z’ëžÊº}jšFšÿ¶ Ý`æ†Òi>{œ’Ÿô•¶G A-& K }(ŒëéÅâóx…<³æ¬ÿ w}c™ºëV 8¨9¯f…|…<ÙžBG>]…Öæd1 :dm~¡ dߊċM²o׃v¼á–%Û¿Y¸—Åäs÷‘D ú5xA¿¿8Â+IË×éê·©IIªá¼pYaààt!&XÀmEæ<šäÈ.Dô`Á€ÑŒ‡·ôZ¸‹(gÝVB]-ž‰±ãºtÃjcðË!ük(”匀JK'‹gcÜ14ªc–uö¹?šÛ;‹ÁoªTo''EÖ£¬ü˜"xò²Lé†_ =‚´$ŸËIc—çĉbꕨ ùWU’‘î±Å"HꢟĘs퇳Goò]kÛ/­{,]Gý£+™78&v£Xi:B,Æþ!ÑÍG"*qÇ„QŸÊ¨!24ý„óü_!¼¡/§þt¨þ"k?hì 0à°>ŽuÌÐ| zÕÕ–ÃclÂŽ!u“Ãqæs©©Rë5ÆH$ÑôÔp•¢uÚYqóŸX­o#—RÀ_\5Ýø_Â?!IgF)/Åeauø'ùAøVždàr¥ËïëÛÞ}¦Y'kÌÕf¸Vóu9 Ø!ˆpˆì£ÿàÿ‚·¸Ôù•e ¨²ÃÁSÕ`¾ž*kB<¥û¼W‰Ê¶Ý¡NÜΫ¸hkÜÓ:DR Éïí~óIÐ6]Dt]s²*\Î8±|ˆ—È*‘ðä£ß¯×‰lR˜ß½äs >kܱO}<§ç|Oœ¶A)«C Ç)Êã©BóÝÈà´™á©(t*Õµ× +l !2áN»/¥×E>`S®,RºQ#bñM,ÚTYb}+`Ç6’¶Ãk†Ge9âÓ!ž6$?Ôì]hòJ¾«´.‡?ƒ‡Y Š¶‘@ŠwÔ°§Ød›lð¦ÝÔp´–t»ôègURÉ¡-¾(r _,—·ŒÖR‚ýnuX)"îV@.2*I¸/`>/ÿ™” ý{ÔV­9òªÊ7î >eÅ€ ïM—N­º‘Í\N#ÂÉ/ó­ +§ð‰úL|$ö!dÚ JˆÞKØ}-T´æ×;¡«0_Õ, k‰ÉÃ>¾!¶:1êOSËêt0JÝ@ýuþGX“÷SBgc/ˆÔƒ N<Û^‚»ž9 îÇÉÕ”¿\”ÀÆIŒ˜4j¸Õ“9½„;¶kÜ ŽaϘ:ŠEM +P˜lŒe£’ã+£¥¹ pkùë¶ØÉÇT¶l®^,XÀ¾ÝeÍì”_õUJ€e@Çy¨}+”æ‚b ø‰lK±ŒWZ:‚,cy‰Ÿf0þ\‹Î0ZÂS²üä»E>âû¸—˧=ì¥zpGŒ™\Êyª¾+[[øy§›ç—ü ŸZt3Ïß.°ãxciå•^žÉ;'îÚAórMÐÓו;ò]¨†=¿Ž8?±V«Ÿ·6ÞyÉÊ¿UþGF¡œ§-m4@ðwcÚ"鹑ÄVôÒμaU-È#Îåc¸Hd#›Ä]EJ†:äI/ï¦ä]S0­÷¾Ìä_àÃCË䆄ٸœàm”ÇäÚù0 ±óW,Di$éyüw*Ë•c„kß÷•è#ˆ:G Ž›h‘ˆjë-RXvtªd?ÒX•ÀKaäkõZ|˜^ÌÉ2biBë˜Müâ²ëŠdÐ0F¿Æ(®glûþÓ†‡ÍIc“ïÔ™KYV›ž…:Áç_Ùg‘—7±ûêèúÞïµ.Àè ‚·>iïî@3Ž&øÒ¯ˆ¼±I~ž ÿSMeÀÖÃBaåò¢³•=܇¹ O‡–8G¯që¼ áA;8ÑÿÄalUïûé‹`Îé½>¼vð_Ô#*åA" (NÍ?Y‘z{µÍÊZU'‡Û4.¬…"Qkƒ˜o¸ÏÁswaë èöœž:£7F{ *‚¯hw,btzdt‰hŠð.}Ä˺Ø_p:\lGoû]v†ëý%ÝìïÅù†âJ4ª 7†¯èçYÏ=ìî‘}Ã`%WgE£ +GuE»D‰ãÔ¥Âóñ;ïdœÏè!”/Àó1ƒkI—ìf„YYZ-©ÄMiÊÈ]×þ$ƒ­·‡!ûr +LTºVú=Êo•È +Û½â˜ÆPäè§ß¸Bë­xÞ=$ŽÏ-Ê6){wk(@øüáÕðOHUBù ?¡rl¯²éëú6c‹Ó>uÒ”½ŸIñh Õ¯­¹Æ½U}«zÚ$ß“¦$j ðW“£Bê¢_= D#0 ˜ÈExŒ”âZÂiܤŠI}ÈïÕ¯jÿW|ÆœÍÚˆMåyÄÞ-[ÄÌÙÓåØ…ªÙ Þ¥¼U$ÜbxÕÒÊ„&ÓPïžõznƒXAz^ »ë|YÈ:ËšpÅxSe´è´9k +Ýu»ƒ¤¸ÞmÚÞ Dvâ¤äÆÞ +Õó”I¶èb×£~)©œbèXŸ²|îOÀ&‰g IÕ'u!Àª77Xñ*”() ÿ×ÎÝ¥}iTl,K½Í¯¾l +ܹ×P/…úo=ûºK5þ)k¸Å9û ð,!P´_€ƒšù"£Æ#AÅÛ4ì–¹l1CUêï_fE«ô¸iôÉNat u…œŒáóˆó¼Ï*¦Š¦Hæ6ƒùV¿Ÿ´¶V ‡F²À+ððDÌ™¸C~Zk+‘MÅ +´ JT<Ê5Jŵ±E]Ì+D·ô>B‡™µœ8ÏË]8ÀT¨hØÙ'/¶!7…˜ë?ÙT¯knÓGÇá‹ê »¤R—Õo7ìy>À¬")Ɉ @aãÂÜN JÚÃ?Ô$O@_ñÆ,Õa4Æ€yüü@—+® ±Û;Ç`FõËëZvØÌǺֺí®eeG X›­~¾·õ&éÏeu`¸—ŽOä×£Æe–h€Ìy¿@Ÿ’“WÒ)¯é%uã7¦34T^¥„úvšh ά$· ƒ´—sú‡ÿ“¡ïvž¬,ôµÁÄ$ º™úë·“°xR¿|£î¿Ãó Ú,W]×¥¦ûÍ#0* 4¯ÿ¸>xÊf'…—FIc—„Ø‹eøt7™Ù;e;¡Ë¯¯y– ±*ÂR÷ /òr3}KÙsÚ9¨ 6{÷ŒW?iöøê#ÓU¬ geV}y¶ï Ý¬LÓ÷ÏqùãÄ#nÊ›ÒƧ©W“d§³1ªvÛ»âôE“¦õÌg]òÈeÕýÄqÍø<™ý’RZÞ=’~­²‡¥WôúÂyÁÈé4x*-Â%VÒV‘µÕ¶Q -ЇMÖhaQdÓ©y?fx“>ˆ¯é> ¶¾•QN÷[sæ€÷¦v ýó»¥à.ŒXý…p²ràu -Ý´Ÿ×+I^DîŒO ;6wùôçÛ‡ØüÂQ—‚FoAî8OÉ»ßþ¿)—û?êA=+(*ÜêíŠa‚jL¼ï‹¾êîë2)㪼PªŠæRö*™Cšìã*±(Œâ}syXïqÃ%+8Çx’.MÚ½4cU¤bðä÷€{3]ö*ƒ‹ƒs´ˆuSsŽñ–Ïr{ªæAQªÏ*kóÓ.‹VÀ¾ÞÑ_a ;ýÐÙ\rß’ab¬2 ¾:GÍéO/Ã>q›FÝá'àRÍ$5*:8Æ~K[¸ÌŸ/®çDh_%1ƒ}ÔVp}ñª#Ë\/9`ìÌS/ÌÚ |ƒ¯òÔVa؉šÏs026êæž,G…âWd—=™ÝpH§oÌ×À6ð<2ân^×ióòbkÊ—µu!©ƒsâÔ³Íàr¶¿bß{vb)æß`¯ê7c<û­ƒGöN7€%è§6µ$½æÇPŠ¨’ÑB¦[¸öNÃ/f ÂU¡@]k~'/_ú<útX4ŽG¶\Ú£’\3-2»Š —¦¡øm8Ê œ/4–3ló”°»ªo¡êˆVD 8¡½¼Aèžü€ÅAwçØSªSg:ÇÒY¥ø²‹—óà‡pµ´á£«ê©‹oâ·,>“ͧH7ÛáÄ`Åø"ÈoÕ¶÷ƒ˜NF^¾ÂJÙ}—-ý‚c½\ž¹­ÉsY(óA7È,™ýÝz*Öñ\ÖŸ¯ˆ_ãë~úÀ ¼|¸O¤ñ +¥œhÿNNƒ9¨vG'Ug¸¨4ÅR1L°¹}¥ÙݷϺªä7œAr"²sÿå]DÌœáÖ*²˜fâ8>5ˆ#!†ô]Üù™J@oxžÀqñróä°h߬ÿÜÙÚ¹­ˆ µj˜ŒB˜þ  ¯Jž•eŠ´)îõ5Ëè–·71Ó¬Q^uÝÜ\ŸÄ#™:<+ÈŠ1Ÿ¸ÿ38¹‘¬2ÉœØiB+WT^"a®›‚×~Þ݆ëJÇ7ûXi0þ`–ýù'_ý&²ïôïEÕg̦ËÌn¾ŸË3n “e‹”œÅƒd¦ÓTÝÈF<>p«Öþ .2©Ä©· ?ÈÆjãÙ¦}ÝÉ °¾³jäÎXXcT¹7J B)ºÔNc6+Ö'ý¢dþ +F¨m©‡.]mD!±]ØÐâYp¸lk`ìÃJ‡ ŒsTBV‘´¸¶Ÿe¾œ¿ì¡½. kð£Û90þÐTô“£ö»ÔÒñÓÅʶ¢¸úûëņ¼¸ræØKj,fóh‚3ªøÿ2–¸‰Àzz9=d=„ÁÒ¡¦9|4㘤õophg÷\©T‹I¬â6—ŒÑÃ’þÒ‹®€3îݪ¨¶µ§RTãµ=$Ê?ìåøA“ªâdß`UÆ`Áߌù$ì{sÑ¥ * ÷.ÀÅV™ÿlyÈøšÆK ¤jØfkè±ê œy¬úÈÁØ’¸ëµ:w¥¾iÑÀï{z³½¨NÙƒZ]¡øŒÓõâŒd_‰è…"¸HJã?óíe`“ò¡:µ0H´-Q1“±vôØC¹”§ªt-T"wé‹ý·)×µý‹{pδémF6©ÖùªgM_é´“Õ0(K(mÏ`ŒçWkà‘m–•Ûyªâ¯ÿù+Ž0„ugÈI·¡f>W³ +Æ…ˆÏ›£7úÆ-ÆD¨iJýGÁú_)æut³ãU +"ŸÞ¯,Ô%ULÚ€bM!¡qÄxE~ÛAls.4•ÜðfÜH"\¸£Ô± _‘wýgB™8LMLUyÈÞa™·sÚìš¡ôøj¹½ÒžÓ½‡¡ D¢Èš +7nOºƒåä´WHg~‰Ð7I'‹· +È·‹”÷íÌéß[MV§w ›¶7€‹ÑSÏMR”šõ…4Æ;Èð J?¶Œ¾jÑ¿®J\ëˆ7ÁûÌK–p (WñcB¨3 ¹±ºÈ‘@³Ô_úzdx¢¨dURéë .ç·Ìº5m—s€¸HöÃIxIrtæ0Y"·tð/Y ºn÷.ˆYõ¹³÷Uù¼wAúYõ¤“Êža£ QI–4s™Í·`Zq{x7â¢3K¨œÕSŽ6öF‹pJÅŸó¨Ê÷‰³`å‚ý×m,ÝŠ!ˆiâD'@).¦cîºA ¿ÞÊëÄöFkÃÞûa²G34ßÌLkubÕÝuŽ`—µwƒmS0á-§û®.Þï)ZˆÄ/Ô¥ñwhC +M-¶.FŒÿµäx*Ièwìï jå¿ñOÀ i㟧:eȶIêÅ¿:ÜŠHúݧ-rh\ï'ÓùÌ’R¥_TÐþgGP îZŸöÁqæuSÛAž­§…³AÖñÂ2ò,ᇉ–^Ï’¦O?é¹ðÒM³w6”BûIxöp²Dðy,Ö4™ÚÕ“‹ÏAøG½.þÂWA'R¿(ZÕÇh³8Ï¿?ŠÇ3'„ªù]érmRKbw`wó–óBSv£g‰MqL&"d4îßÿÔEÔ(ýÄ{Û´qt¡f[A\ªÊ»t1ÇžÛR˜Ry# “dE‡âtÞúµju Y‰¤*2¬Î?°….T°ÿ2>G”íº«vwtj3Ň^!E÷3Õ廢XUZ _|lï±ï«m«E_ržÄ/ª-ϳÙ½Øë'ÏÕI¶ÊLàRQdÓ[<ásöŒ }û6cͱè$—ù<ÍÉw±x±ÐÊFÙVc$h»1Ùƒ#9×çáË "§+^t¶éŠ¡¤ÿØ+M_êv+ÿVG10>âaþñË´T®ô•´ °‡ñùC +,ÔOjÊŠb¶¹?×›:m’~¶—U¹]†¤^Eù_âJÁðê cì¬ÆçiG·:ôO¨—K´Ã¡]ÚQHqûçz2n_y–ÌÞ#u®B4¤ìoXêLÇ7:nÍT5úF÷µÎ×—ˆÓ)™´ç„L81ÿC“Å [bPˆN.ï‹™u{‘®œ2eá¢À÷ÀÄ$ †^%°ú8¦=¯%’Iñ%žu-^"mÈ.¤Û¸~Ð:k@ju÷…¾c£Ïëd´"k¤Dm¿â†ZûÏÙ±˜÷TMcí"GÎÏÎtd$.¹Ù ¢$ ¬ *ñ/éa+±wz£(±üŒÔSNNÇÒ4jUí@®7–K‡Ìu7$-椟xP€‡ÔUõ?¦ÕÄÉÂû²ûåïÅv§0&T­ ÙtÞ8'þùë9=‹º=!ô̽ÀE²µ‰'Ñ€¡l>Óöb¾è®ÿdï"}rÊûô hC¢A”•i\´¿Ž88¿¿Ã;B8¼ŽRp³g¨FaT“9µ•¯%:$¦é+§Jhn¹ˆ Õöߢªñ©û¾×ý†&ê[KâÂ4¢5Ç?ø‡Û‘R<~cù­¬ÒòL½Ùso»øóEópdÐអػTÝ°ÝÆj\#…2 ¨ðØšÝFâ”)ü^ ¢¸5à.6ô + kÇØ4‚¥Ý—ÙŠ‘3ÂJœâý)åb·oß®k ‚Á@IÂé¹ÜÈÃ_wz   +eÞòHÔÀxwœ.¹=lÞÐO:ü¦Ð‡(Ú=•­V{/k?¿IÉbà"ï9çºRùd³Êxq¡+'ͺúíïšh®'ˆ¬Â{í1ŒÀetb|Ñž¬™!ðÕݱ +s£7ƒæM9-‘ùÆìª@¯Ð®R³±îB#„:Þ‰À×£‚lÉV÷ÌŒÜeƒ¶üUw²ÚÄ¿J·"™1 ×C±W|M`¯/ˆ©ïÑÕn­Æ$è”õÎÓÏw³½íΛ_®×7SŸ£¬›¹¿ `²Îkss½Þ‰o1½,ÈíÂؽ„­IIøßÏäŠÁÖs>9y U.Ï&†²Ëï:Ü.mQG-+ñ´N‚êÌM¢91 endstream endobj 1899 0 obj @@ -26205,19 +26212,19 @@ endobj /Type /ObjStm /N 100 /First 1006 -/Length 17043 +/Length 17038 >> stream 1860 0 1862 285 1864 933 1866 1363 1868 1786 1870 2035 1872 2277 1874 2605 1876 2822 1878 3061 1880 3283 1882 3820 1884 4057 1886 4305 1888 4687 1890 5053 1892 5392 1894 5623 1896 5996 1898 6259 -1900 6743 1902 6975 560 7259 558 7400 1656 7541 1630 7682 755 7824 802 7965 771 8106 1815 8246 -561 8386 773 8526 770 8664 775 8802 1211 8941 772 9081 1125 9221 735 9360 559 9501 769 9642 -830 9783 962 9923 562 10063 736 10176 831 10289 887 10402 922 10515 953 10628 999 10741 1053 10859 -1102 10979 1158 11099 1212 11219 1268 11339 1309 11459 1348 11579 1400 11699 1439 11819 1473 11939 1511 12059 -1553 12179 1584 12299 1617 12419 1680 12539 1717 12659 1755 12779 1793 12899 1836 13019 1903 13103 1904 13218 -1905 13338 1906 13459 1907 13580 1908 13664 1909 13760 550 13829 546 13889 542 14000 538 14074 534 14162 -530 14250 526 14338 522 14426 518 14500 514 14625 510 14699 506 14787 502 14875 498 14963 494 15051 -490 15125 486 15250 482 15324 478 15412 474 15500 470 15574 466 15699 462 15773 458 15861 454 15949 +1900 6738 1902 6970 560 7254 558 7395 1656 7536 1630 7677 755 7819 802 7960 771 8101 1815 8241 +561 8381 773 8521 770 8659 775 8797 1211 8936 772 9076 1125 9216 735 9355 559 9496 769 9637 +830 9778 967 9918 562 10058 736 10171 831 10284 887 10397 922 10510 953 10623 999 10736 1053 10854 +1102 10974 1158 11094 1212 11214 1268 11334 1309 11454 1348 11574 1400 11694 1439 11814 1473 11934 1511 12054 +1553 12174 1584 12294 1617 12414 1680 12534 1717 12654 1755 12774 1793 12894 1836 13014 1903 13098 1904 13213 +1905 13333 1906 13454 1907 13575 1908 13659 1909 13755 550 13824 546 13884 542 13995 538 14069 534 14157 +530 14245 526 14333 522 14421 518 14495 514 14620 510 14694 506 14782 502 14870 498 14958 494 15046 +490 15120 486 15245 482 15319 478 15407 474 15495 470 15569 466 15694 462 15768 458 15856 454 15944 % 1860 0 obj [726.9 688.4 700 738.4 663.4 638.4 756.7 726.9 376.9 513.4 751.9 613.4 876.9 726.9 750 663.4 750 713.4 550 700 726.9 726.9 976.9 726.9 726.9 600 300 500 300 500 300 300 500 450 450 500 450 300 450 500 300 300 450 250 800 550 500 500 450 412.5 400 325 525 450 650 450 475] % 1862 0 obj @@ -26480,7 +26487,7 @@ stream % 1898 0 obj << /Type /FontDescriptor -/FontName /BGSLBR+CMTT10 +/FontName /TJSMYH+CMTT10 /Flags 4 /FontBBox [-4 -233 537 696] /Ascent 611 @@ -26489,7 +26496,7 @@ stream /ItalicAngle 0 /StemV 69 /XHeight 431 -/CharSet (/A/B/C/D/E/F/I/K/L/M/N/O/P/R/S/T/U/W/Y/a/ampersand/asciitilde/asterisk/b/backslash/bracketleft/bracketright/c/colon/comma/d/e/equal/f/four/g/h/hyphen/i/j/k/l/m/n/nine/o/one/p/parenleft/parenright/percent/period/plus/q/r/s/six/slash/t/three/two/u/underscore/v/w/x/y/z/zero) +/CharSet (/A/B/C/D/E/F/I/K/L/M/N/O/P/R/S/T/U/W/Y/a/ampersand/asciitilde/asterisk/b/backslash/bracketleft/bracketright/c/colon/comma/d/e/equal/f/four/g/h/hyphen/i/j/k/l/m/n/o/one/p/parenleft/parenright/percent/period/plus/q/r/s/six/slash/t/three/two/u/underscore/v/w/x/y/z/zero) /FontFile 1897 0 R >> % 1900 0 obj @@ -26696,7 +26703,7 @@ stream << /Type /Font /Subtype /Type1 -/BaseFont /BGSLBR+CMTT10 +/BaseFont /TJSMYH+CMTT10 /FontDescriptor 1898 0 R /FirstChar 37 /LastChar 126 @@ -26712,7 +26719,7 @@ stream /LastChar 116 /Widths 1848 0 R >> -% 962 0 obj +% 967 0 obj << /Type /Font /Subtype /Type1 @@ -26741,7 +26748,7 @@ stream /Type /Pages /Count 6 /Parent 1903 0 R -/Kids [813 0 R 835 0 R 846 0 R 856 0 R 869 0 R 880 0 R] +/Kids [813 0 R 835 0 R 846 0 R 854 0 R 865 0 R 880 0 R] >> % 887 0 obj << @@ -26762,7 +26769,7 @@ stream /Type /Pages /Count 6 /Parent 1903 0 R -/Kids [950 0 R 958 0 R 965 0 R 969 0 R 980 0 R 986 0 R] +/Kids [950 0 R 958 0 R 964 0 R 969 0 R 980 0 R 986 0 R] >> % 999 0 obj << @@ -28148,17 +28155,17 @@ stream >> % 1920 0 obj << -/Names [(Item.23) 839 0 R (Item.24) 840 0 R (Item.25) 841 0 R (Item.26) 842 0 R (Item.27) 843 0 R (Item.28) 859 0 R] +/Names [(Item.23) 839 0 R (Item.24) 840 0 R (Item.25) 841 0 R (Item.26) 842 0 R (Item.27) 843 0 R (Item.28) 857 0 R] /Limits [(Item.23) (Item.28)] >> % 1921 0 obj << -/Names [(Item.29) 860 0 R (Item.3) 805 0 R (Item.30) 861 0 R (Item.31) 862 0 R (Item.32) 863 0 R (Item.33) 864 0 R] +/Names [(Item.29) 858 0 R (Item.3) 805 0 R (Item.30) 859 0 R (Item.31) 860 0 R (Item.32) 861 0 R (Item.33) 868 0 R] /Limits [(Item.29) (Item.33)] >> % 1922 0 obj << -/Names [(Item.34) 865 0 R (Item.35) 866 0 R (Item.36) 867 0 R (Item.37) 872 0 R (Item.38) 873 0 R (Item.39) 874 0 R] +/Names [(Item.34) 869 0 R (Item.35) 870 0 R (Item.36) 871 0 R (Item.37) 872 0 R (Item.38) 873 0 R (Item.39) 874 0 R] /Limits [(Item.34) (Item.39)] >> % 1923 0 obj @@ -28223,7 +28230,7 @@ stream >> % 1935 0 obj << -/Names [(cite.DesPat:11) 739 0 R (cite.DesignPatterns) 903 0 R (cite.KIVA3PSBLAS) 1835 0 R (cite.METIS) 777 0 R (cite.MPI1) 1841 0 R (cite.PARA04FOREST) 1833 0 R] +/Names [(cite.DesPat:11) 739 0 R (cite.DesignPatterns) 902 0 R (cite.KIVA3PSBLAS) 1835 0 R (cite.METIS) 777 0 R (cite.MPI1) 1841 0 R (cite.PARA04FOREST) 1833 0 R] /Limits [(cite.DesPat:11) (cite.PARA04FOREST)] >> % 1936 0 obj @@ -28238,7 +28245,7 @@ stream >> % 1938 0 obj << -/Names [(figure.10) 1649 0 R (figure.2) 785 0 R (figure.3) 876 0 R (figure.4) 902 0 R (figure.5) 942 0 R (figure.6) 963 0 R] +/Names [(figure.10) 1649 0 R (figure.2) 785 0 R (figure.3) 876 0 R (figure.4) 903 0 R (figure.5) 942 0 R (figure.6) 962 0 R] /Limits [(figure.10) (figure.6)] >> % 1939 0 obj @@ -28308,7 +28315,7 @@ stream >> % 1952 0 obj << -/Names [(lstnumber.-9.6) 1661 0 R (lstnumber.-9.7) 1662 0 R (lstnumber.-9.8) 1663 0 R (lstnumber.-9.9) 1664 0 R (page.1) 556 0 R (page.10) 858 0 R] +/Names [(lstnumber.-9.6) 1661 0 R (lstnumber.-9.7) 1662 0 R (lstnumber.-9.8) 1663 0 R (lstnumber.-9.9) 1664 0 R (page.1) 556 0 R (page.10) 856 0 R] /Limits [(lstnumber.-9.6) (page.10)] >> % 1953 0 obj @@ -28318,7 +28325,7 @@ stream >> % 1954 0 obj << -/Names [(page.106) 1571 0 R (page.107) 1575 0 R (page.108) 1579 0 R (page.109) 1583 0 R (page.11) 871 0 R (page.110) 1588 0 R] +/Names [(page.106) 1571 0 R (page.107) 1575 0 R (page.108) 1579 0 R (page.109) 1583 0 R (page.11) 867 0 R (page.110) 1588 0 R] /Limits [(page.106) (page.110)] >> % 1955 0 obj @@ -28363,7 +28370,7 @@ stream >> % 1963 0 obj << -/Names [(page.23) 940 0 R (page.24) 946 0 R (page.25) 952 0 R (page.26) 960 0 R (page.27) 967 0 R (page.28) 971 0 R] +/Names [(page.23) 940 0 R (page.24) 946 0 R (page.25) 952 0 R (page.26) 960 0 R (page.27) 966 0 R (page.28) 971 0 R] /Limits [(page.23) (page.28)] >> % 1964 0 obj @@ -28551,11 +28558,11 @@ endstream endobj 2028 0 obj << - /Title (Parallel Sparse BLAS V. 3.6.0) /Subject (Parallel Sparse Basic Linear Algebra Subroutines) /Keywords (Computer Science Linear Algebra Fluid Dynamics Parallel Linux MPI PSBLAS Iterative Solvers Preconditioners) /Creator (pdfLaTeX) /Producer ($Id$) /Author()/Title()/Subject()/Creator(LaTeX with hyperref package)/Producer(pdfTeX-1.40.17)/Keywords() -/CreationDate (D:20181011090433+01'00') -/ModDate (D:20181011090433+01'00') + /Title (Parallel Sparse BLAS V. 3.6.0) /Subject (Parallel Sparse Basic Linear Algebra Subroutines) /Keywords (Computer Science Linear Algebra Fluid Dynamics Parallel Linux MPI PSBLAS Iterative Solvers Preconditioners) /Creator (pdfLaTeX) /Producer ($Id$) /Author()/Title()/Subject()/Creator(LaTeX with hyperref package)/Producer(pdfTeX-1.40.18)/Keywords() +/CreationDate (D:20181028180128Z) +/ModDate (D:20181028180128Z) /Trapped /False -/PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.17 (TeX Live 2016) kpathsea version 6.2.2) +/PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.18 (TeX Live 2017) kpathsea version 6.2.3) >> endobj 2001 0 obj @@ -28718,47 +28725,46 @@ endobj /W [1 3 1] /Root 2027 0 R /Info 2028 0 R -/ID [<40F15E8DF9A4249227B6550011EFEDD4> <40F15E8DF9A4249227B6550011EFEDD4>] +/ID [ ] /Length 10150 >> stream ÿ”Nw Í+w Í5w Í=wÍIw  -ÍRw  @w @w@w@w@6w@7w@=vc@>vb@?va@Cv` @Dv_!"@Ev^#$@Iv]%&@Kv\'(@Lv[)*@SvZ+,@TvY-.@[vX/0@\vW12@]vV34@avU56@cvT78‘vS9:‘vR;<‘vQ=>‘vP?@‘ -vOAB‘ vNCD‘vMEF‘vLGH‘vKIJ‘vJKL‘vIMN‘vHOP‘vGQR‘!vFST‘"vEUV‘(vDWX‘)vCYZ‘*vB[\‘+vA]^‘1v@_`‘7v?ab‘8v>c˹‘;v=ËË‘Bv<ËË‘Lv;ËË‘\v:ËËó v9Ë Ë +ÍRw  @w @w@w@w@;w@<w@=vc@>vb@Bva@Cv` @Dv_!"@Hv^#$@Iv]%&@Kv\'(@Lv[)*@SvZ+,@TvY-.@[vX/0@\vW12@]vV34@avU56@cvT78‘vS9:‘vR;<‘vQ=>‘ vP?@‘ +vOAB‘vNCD‘vMEF‘vLGH‘vKIJ‘vJKL‘vIMN‘vHOP‘ vGQR‘!vFST‘"vEUV‘(vDWX‘)vCYZ‘*vB[\‘0vA]^‘5v@_`‘6v?ab‘7v>c˹‘>v=ËË‘Bv<ËË‘Lv;ËË‘\v:ËËó v9Ë Ë óv8Ë Ë ó)v7Ë Ëó1v6ËËóBv5ËËóMv4ËËó^v3ËË^v2ËË^v1ËË^v0ËË^%v/ËË^:v.ËË ^Av-Ë!Ë"^[v,Ë#Ë$Ôv+Ë%Ë&Ô$v*Ë'Ë(Ô1v)Ë)Ë*Ô2v(Ë+Ë,ÔIv'Ë-Ë.ÔVv&Ë/Ë0Ô]v%Ë1Ë2Ôbv$Ë3Ë4Cv#Ë5Ë6Cv"Ë7Ë8Cv!Ë9Ë:C+v Ë;Ë<C:vË=Ë>C@vË?Ë@CGvËAËBCMvËCËDCYvËEËFC_vËGËHCcvËIËJªvËKËLªvËMËNªvËOËPªvËQËRªvËSËTª%vËUËVª+vËWËXª2vËYËZª9vË[Ë\ªFvË]Ë^ªJvË_Ë`ªZv ËaËbª^v Ëc”j¥v ””v ”” v ””v””v” ” v” ” v” ”!v””%v””+v””1v””7v””=Ec””CEb””JEa””OE`”” VE_”!”"‘E^”#”$‘E]”%”&‘ E\”'”(‘&E[”)”*‘,EZ”+”,‘1EY”-”.‘8EX”/”0‘?EW”1”2‘EEV”3”4‘LEU”5”6‘RET”7”8‘XES”9”:‘^ER”;”<ëEQ”=”>ëEP”?”@ëEO”A”BëEN”C”DëEM”E”Fë!EL”G”Hë'EK”I”J”K”O$ü”L”MEE&EEE*”R”P'”Q”T”U”V”W”X”Y”Z”[”\”]”^”_”`”a”b”ckkkkkkkkkk k k k k kkkkkkkkkkkkkkkkk"k ”S( kksk#k$k%k&k'k(k)k*k+k,k-k.k/k0k1k2k3k4k5k6k7k8k9k:k;k<k=k>k?k@kAkBkCkDkEkFkGkHkIkJkKkLkMkNkOkPkTkRk!†ÙkQkUkVkWkXkYkZk[k\k]k^k_k`kakbkcÍÍÍÍÍÍÍÍÍÍ Í -Í Í Í ÍÍÍÍÍÍÍÍÍÍÍÍÍÍkS×ÕÍ:¢ÍÍ]¨ÍÍ!Í"Í#Í$Í%Í&Í'Í(Í)Í*Í,Í ^3E%E+ëNëEë;ëOëMëBëCëLë?ë@Í2Í3Í4•¼Í9Í7Í-µEÍ6Í.Í/Í0Í1šrëAÍ:Í;Í@Í8¦Í<E'E EE#EÍ>E!Í?ëKÍEÍFÞÍJÍAÈçÍGÍHÍBÍCÍDë>ë=ÍLÍMÍOÍKä¯ÍNÍ]Í[ÍPúAÍQEÍSÍTÍUÍVÍWÍXÍYÍZ@ @ Í\PÍ^Í_Í`ÍaÍbÍc@@@@@@@@@E(E,^º@ @@ -mŸ@ @@@@@@@@@‹ @@@@ @!@.@/@,@¬@@"@#@$@%@&@'@(@)@*@+@8@-Ç'@0@1@2@3@4@5@:@;@@@9Ü@<@F@Aðì@BE-@M@G@H@J@O@P@Q@X@Nù@R@U@V@WëJ@^@Y?@Z‘@_Oˆ@`@bª‘‘‚‘‘ ‘•+‘ E.‘‘ ¦‘‘‘µ‚‘‘‘È•‘‘‘‘$‘ÛS‘ ‘#‘'‘,‘%ù‘&‘.‘/‘2‘-,‘0E/‘M‘4‘5‘<‘3>‘6‘9E)‘:‘?‘=/‘>‘C‘@2±‘A‘E‘F‘G‘H‘I‘J‘P‘N‘D3‹‘K‘Q‘R‘T‘OPˆ‘S‘V‘W‘X‘Y‘Z‘^‘U[#‘[‘]E0‘`ó‘_ys‘a‘b‘cóóóóÄãóóóó ó -ó óóµÊó óóó×óóóóóóÙÃóóó#óôÊóóóóó ó!ó"ó%ó&ó'ó+ó$Úó(ó*E1ó-ó.ó/ó3ó,Íó0ó2ó<ó4;öó5ó6ó7ó8ó9ó:ó;ó>ó?ó@óDó=KYóAóCóGóEhMóFóIóJóKóOóHjúóLóNóXóP„uóQóRóSóTóUóVóWE2óZó[ó\ó`óY–Ëó]ó_óbóc^óa¯^^j²^^^ -^ðƒ^E$^ ^ ^ ^^^^^ S^^^^^^^^^^^^^!^#0^ ^#^)^'^">¬^$^&E3^*^+^,^-^.^/^1^(Yl^0^3^4^6^2x^5^8^;^7ŠŠ^9^=^>^?^N^F^<R^@^B^C^D^E¶£^O^R^G©ê^P^Q^H^I^J^K^L^MÄþøm^U^S&^TE"E4^W^X^Y^`^V2,^Z^\^]^^^_^b¬Ÿ^cÔÔ^aS‹ÔÔÔÔÔ .ÔÔœ½ÔÔÔ «ÔÔ -Ô Ô Ô ÔÔ»=î¬ÔÔÔÔÔDÔÔÔÔÔÔ ÔAÔE5Ô"Ô*Ô(Ô!GÔ#Ô%Ô&Ô'Ô+Ô,Ô.Ô)e»Ô-Ô3Ô/vMÔ0Ô5Ô8Ô4Ô6Ô7Ô:Ô=Ô9ªAÔ;Ô<ÔEÔ>Ñ¿Ô?Ô@ÔAÔBÔCÔDE6ÔGÔJÔFÜ`ÔHÔLÔQÔKø ÔMÔNÔOÔPÔSÔTÔXÔR 1ÔUÔWÔZÔ[Ô^ÔY ùÔ\Ô`ÔcÔ_ %ÔaCCCC YïC -_DE7C -C qSCCC C C CC  wÃCCCCCCCCC ‹CC&C ¤‰CCCCC C!C"C#C$C%C(C)C,C' ¼C*C5C- ÖÂC.C/C0C1C2C3C4E8C7C8C;C6 ßÇC9C=C>CBC< ìC?CACDCECHCC ûäCFCJCKCNCI -CLCSCO -*öCPCQCRCUCVCWCZCT -/ŽCXE9C\C]C`C[ -D*C^ªCa -QšCb ­*ªªª -‰*ªª +Í Í Í ÍÍÍÍÍÍÍÍÍÍÍÍÍÍkS×ÕÍ:³ÍÍ]¨ÍÍ!Í"Í#Í$Í%Í&Í'Í(Í)Í*Í,Í ^3E%E+ëNëEë;ëOëMëBëCëLë?ë@Í2Í3Í4•¼Í9Í7Í-µEÍ6Í.Í/Í0Í1šrëAÍ:Í;Í@Í8¦Í<E'E EE#EÍ>E!Í?ëKÍEÍFÞÍJÍAÈçÍGÍHÍBÍCÍDë>ë=ÍLÍMÍOÍKä¯ÍNÍ]Í[ÍPúAÍQEÍSÍTÍUÍVÍWÍXÍYÍZ@ @ Í\PÍ^Í_Í`ÍaÍbÍc@@@@@@@@@E(E,]R@ @@ +m°@ @@@@@@@@@‹@@@@ @!@(@¬i@"@#@$@%@&@'@*@+@6@)ÇP@,@-@.@/@0@1@2@3@4@5@8@9@?@7ÛÆ@:@E@@ðQ@AE-@M@Fe@G@J@O@P@Q@W@N”@R@U@VëJ@Z@^@X:?@Y‘@_Ok@`@b°‘‘€·‘‘ ‘n‘E.‘‘ ¡£‘ ‘‘±Ë‘‘‘ÁÇ‘‘‘‘$‘׌‘‘#‘'‘+‘%õâ‘&‘-‘.‘1‘,’‘/E/‘M‘3‘;‘9‘2Ë‘4‘8‘=‘?‘:&3‘<E)‘C‘@4·‘A‘E‘F‘G‘H‘I‘J‘P‘N‘D5‘‘K‘Q‘R‘T‘ORŽ‘S‘V‘W‘X‘Y‘Z‘^‘U])‘[‘]E0‘`ó‘_{y‘a‘b‘cóóóóÇóóóó ó +ó óó·÷ó óóóÙBóóóóóóÛðóóó#óö÷óóóóó ó!ó"ó%ó&ó'ó+ó$ ó(ó*E1ó-ó.ó/ó3ó,!úó0ó2ó<ó4>#ó5ó6ó7ó8ó9ó:ó;ó>ó?ó@óDó=M†óAóCóGóEjzóFóIóJóKóOóHm'óLóNóXóP†¢óQóRóSóTóUóVóWE2óZó[ó\ó`óY˜øó]ó_óbóc^óa±G^^là^^^ +^ò°^E$^ ^ ^ ^^^^^ €^^^^^^^^^^^^^!^%]^ ^#^)^'^"@Ú^$^&E3^*^+^,^-^.^/^1^([š^0^3^4^6^2zD^5^8^;^7Œ¸^9^=^>^?^N^F^<€^@^B^C^D^E¸Ñ^O^R^G¬^P^Q^H^I^J^K^L^MÇ,ú›^U^S(3^TE"E4^W^X^Y^`^V4Z^Z^\^]^^^_^b®È^cÔÔ^aU¹ÔÔÔÔÔ 0,ÔÔžæÔÔÔ ­FÔÔ +Ô Ô Ô ÔÔ½fðÕÔÔÔÔÔmÔÔÔÔÔÔ ÔC@ÔE5Ô"Ô*Ô(Ô!I,Ô#Ô%Ô&Ô'Ô+Ô,Ô.Ô)gäÔ-Ô3Ô/xvÔ0Ô5Ô8Ô4’?Ô6Ô7Ô:Ô=Ô9¬jÔ;Ô<ÔEÔ>ÓèÔ?Ô@ÔAÔBÔCÔDE6ÔGÔJÔFÞ‰ÔHÔLÔQÔKúÉÔMÔNÔOÔPÔSÔTÔXÔR ZÔUÔWÔZÔ[Ô^ÔY "Ô\Ô`ÔcÔ_ ',ÔaCCCC \C +amE7C +C s|CCC C C CC  yìCCCCCCCCC @CC&C ¦²CCCCC C!C"C#C$C%C(C)C,C' ¾¶C*C5C- ØëC.C/C0C1C2C3C4E8C7C8C;C6 áðC9C=C>CBC< î9C?CACDCECHCC þ CFCJCKCNCI +ACLCSCO +-CPCQCRCUCVCWCZCT +1·CXE9C\C]C`C[ +FSC^ªCa +SÃCb ¯Sªªª +‹Sªª ª -¢úªªª ª ªª  -¥ëª ªªª -¼ªªE:ªªª -É”ªªªª!ª -ÝHªª ª#ª'ª" -ê-ª$ª&ª)ª.ª( -ýêª*ª,ª-ª0ª5ª/ ª1ª3ª4ª7ª:ª6 —ª8E;ª@ª; 2kª<ª=ª>ª?ªBªCªDªGªA A'ªEªKªH QªIªWªL hJªMªNªOªPªQªRªSªTªUªVª[ªX ƒÚªYªaª\ „Òª]ª_ª`E<ªb šÎªc ü¨ - Ô   æ  î° ú¹ ÿ¨E= ±" ; (# @$&'.) 1Ì*,-4/ F(023:5 Z¤689E>@; oX<>?GA „.BDEEFLH œ˜IKQM ±ÎNPSTWR ÆóU‘‘‘X à7YZ[E\]^_`abc‘‘‘‘‘‘‘‘‘‘ ‘ -‘ ‘ ‘ ‘E? á‘‘ Α‘‘‘‘ /–‘‘‘‘#‘ 5I‘‘!‘"‘)‘$ ;æ‘%‘'‘(‘-‘* DZ‘+‘/‘4‘. F±‘0‘2‘3E@‘6‘;‘5 Y¦‘7‘9‘:‘=‘B‘< nZ‘>‘@‘A‘H‘C |ä‘D‘F‘G‘J‘O‘I ‹‘‘K‘M‘N‘U‘P œ‘Q‘S‘T‘Y‘V ©‘WEA‘[‘\‘`‘Z ®x‘]‘_‘b‘cëëë‘a –ë´?ëë<ëë ë -ë ë ëë Âë ëëë Öëëë,‹ëEBëëëë0¥ëë"ë;Œë ë$ë%ë.ë,ë#>ë&ë(ë)ë*ë+Eë/ë0ë1ë3ë-^Çë2ë5ë7ë4z°ë6ëGë8Œ+ë9ë:ë<ëDëFECëQëH§ÎëIëPëRëSëTëUëVëWëXëYëZë[ë\ë]ë^ë_ë`ëaëbëcEò2EîßEGE”6E»½EÙtE›E8™E_ E ~qE -ä*E E %òE g›E§aEÏ Eì­Ew?w@wAwBwCwDwEwFwGwHwIwJwKwLwMwNwOwPwQwRwSwTwUwVwWwXwYwZw[w\w]w^w_w`wawbwcѦÓÑÑÑÑÑÑÑÑÑ Ñ -Ñ Ñ Ñ ÑÑÑÑÑÑÑÑÑÑÑÑѤ’µ| +¥#ªªª ª ªª  +¨ª ªªª +¾¹ªªE:ªªª +˽ªªªª!ª +ßqªª ª#ª'ª" +ìVª$ª&ª)ª.ª( ª*ª,ª-ª0ª5ª/ =ª1ª3ª4ª7ª:ª6 Àª8E;ª@ª; 4”ª<ª=ª>ª?ªBªCªDªGªA CPªEªKªH S¨ªIªWªL jsªMªNªOªPªQªRªSªTªUªVª[ªX †ªYªaª\ †ûª]ª_ª`E<ªb œ÷ªc þé + Öë   è,  ðÙ üâ ÑE= Ú" d (# i$&'.) 3õ*,-4/ HQ023:5 \Í689E>@; q<>?GA †WBDEEFLH žÙIKQM ´NPSTWR É4U‘‘‘X âxYZ[E\]^_`abc‘‘‘‘‘‘‘‘‘‘ ‘ +‘ ‘ ‘ ‘E? ãY‘‘ # ‘‘‘‘‘ 1Õ‘‘‘‘#‘ 7ˆ‘‘!‘"‘)‘$ >%‘%‘'‘(‘-‘* F™‘+‘/‘4‘. Hð‘0‘2‘3E@‘6‘;‘5 [å‘7‘9‘:‘=‘B‘< p™‘>‘@‘A‘H‘C #‘D‘F‘G‘J‘O‘I БK‘M‘N‘U‘P ž]‘Q‘S‘T‘Y‘V «¾‘WEA‘[‘\‘`‘Z °·‘]‘_‘b‘cëëë‘a ÄÕë¶~ëë{ëë ë +ë ë ëë ë ëëë#ëëë.ÊëEBëëëë2äëë"ë=Ëë ë$ë%ë.ë,ë#@^ë&ë(ë)ë*ë+Eë/ë0ë1ë3ë-aë2ë5ë7ë4|ïë6ëGë8Žjë9ë:ë<ëDëFECëQëHª ëIëPëRëSëTëUëVëWëXëYëZë[ë\ë]ë^ë_ë`ëaëbëcEó–EñEI^E–uE½üEÛ³EÚE:ØEaKE €°E +æiE VE (1E iÚE© EÑKEîìE>¯En&E»±EËæEEDEEEFEGEHEIEJ6‚\ƒw w wwwwwwwwwwwwwwwwwww w!w"w#w$w%w&w'w(w)w*w+w,w-w.w/w0w1w2w3w4w5w6w7w8w9w:w;w<w=w>w?w@wAwBwCwDwEwFwGwHwIwJwKwLwMwNwOwPwQwRwSwTwUwVwWwXwYwZw[w\w]w^w_w`wawbwcѨ&ÑÑÑÑÑÑÑÑÑ Ñ +Ñ Ñ Ñ ÑÑÑÑÑÑÑÑÑÑÑÑÑ¥ñ¶Ï endstream endobj startxref -1291644 +1291983 %%EOF diff --git a/docs/src/datastruct.tex b/docs/src/datastruct.tex index 5edb78162..e7766d8e1 100644 --- a/docs/src/datastruct.tex +++ b/docs/src/datastruct.tex @@ -23,14 +23,18 @@ defined in the library as follows: \item[psb\_dpk\_] Kind parameter for long precision real and complex data; corresponds to a \verb|DOUBLE PRECISION| declaration and is normally 8 bytes; -\item[psb\_ipk\_] Kind parameter for integer data; - with default build options this is a 4 bytes integer, but there is - (highly) experimental support for 8-bytes integers; -\item[psb\_mpik\_] Kind parameter for 4-bytes integer data, as is +\item[psb\_mpk\_] Kind parameter for 4-bytes integer data, as is always used by MPI; -\item[psb\_long\_int\_k\_] Kind parameter for long (8 bytes) integers, - which are always used by the \verb|sizeof| methods. +\item[psb\_epk\_] Kind parameter for 8-bytes integer data, as is + always used by the \verb|sizeof| methods; +\item[psb\_ipk\_] Kind parameter for ``local'' integer indices and data; + with default build options this is a 4 bytes integer; +\item[psb\_lpk\_] Kind parameter for ``global'' integer indices and data; + with default build options this is an 8 bytes integer; \end{description} +The integer kinds for local and global indices can be chosen at +configure time to hold 4 or 8 bytes, with the global indices at least +as large as the local ones. Together with the classes attributes we also discuss their methods. Most methods detailed here only act on the local variable, i.e. their action is purely local and asynchronous unless otherwise diff --git a/docs/src/intro.tex b/docs/src/intro.tex index b1dc6e6a8..d0fb9b8c1 100644 --- a/docs/src/intro.tex +++ b/docs/src/intro.tex @@ -362,8 +362,8 @@ follows: backward compatibility}. \item Call the iterative method of choice, e.g. \verb|psb_bicgstab| \end{enumerate} -This is the structure of the sample program -\verb|test/pargen/psb_d_pde3d.f90|. +This is the structure of the sample programs in the directory +\verb|test/pargen/|. For a simulation in which the same discretization mesh is used over multiple time steps, the following structure may be more appropriate: diff --git a/krylov/psb_c_krylov_conv_mod.f90 b/krylov/psb_c_krylov_conv_mod.f90 index e3fcac010..0eb44aab7 100644 --- a/krylov/psb_c_krylov_conv_mod.f90 +++ b/krylov/psb_c_krylov_conv_mod.f90 @@ -61,7 +61,7 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act, ierr(5) + integer(psb_ipk_) :: ictxt, me, np, err_act character(len=20) :: name complex(psb_spk_), allocatable :: r(:) @@ -98,8 +98,7 @@ contains call psb_gefree(r,desc_a,info) case default info=psb_err_invalid_istop_ - ierr(1) = stopc - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/stopc/)) goto 9999 end select if (info /= psb_success_) then @@ -213,7 +212,7 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act, ierr(5) + integer(psb_ipk_) :: ictxt, me, np, err_act character(len=20) :: name type(psb_c_vect_type) :: r @@ -250,8 +249,7 @@ contains call psb_gefree(r,desc_a,info) case default info=psb_err_invalid_istop_ - ierr(1) = stopc - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/stopc/)) goto 9999 end select if (info /= psb_success_) then diff --git a/krylov/psb_cbicg.f90 b/krylov/psb_cbicg.f90 index bb957ef11..fbcc2d030 100644 --- a/krylov/psb_cbicg.f90 +++ b/krylov/psb_cbicg.f90 @@ -116,9 +116,9 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,& type(psb_c_vect_type), allocatable, target :: wwrk(:) type(psb_c_vect_type), pointer :: ww, q, r, p,& & zt, pt, z, rt, qt - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col, istop_, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit logical, parameter :: exchange=.true., noexchange=.false. integer(psb_ipk_), parameter :: irmax = 8 @@ -168,19 +168,18 @@ subroutine psb_cbicg_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_ccg.F90 b/krylov/psb_ccg.F90 index bd16e6571..b98658619 100644 --- a/krylov/psb_ccg.F90 +++ b/krylov/psb_ccg.F90 @@ -114,12 +114,13 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,& Real(psb_spk_), Optional, Intent(out) :: err,cond ! = Local data complex(psb_spk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:) - integer(psb_mpik_), allocatable :: ibl(:), ispl(:), iwrk(:) + integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:) type(psb_c_vect_type), allocatable, target :: wwrk(:) type(psb_c_vect_type), pointer :: q, p, r, z, w complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old - integer(psb_ipk_) :: itmax_, istop_, naux, mglob, it, itx, itrace_,& - & n_col, n_row,err_act, int_err(5), ieg,nspl, istebz + integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,& + & n_col, n_row,err_act, ieg,nspl, istebz + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt real(psb_dpk_) :: derr @@ -160,9 +161,9 @@ subroutine psb_ccg_vect(a,prec,b,x,eps,desc_a,info,& istop_ = 2 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_ccgs.f90 b/krylov/psb_ccgs.f90 index b6542aaee..240f98e62 100644 --- a/krylov/psb_ccgs.f90 +++ b/krylov/psb_ccgs.f90 @@ -114,8 +114,9 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,& type(psb_c_vect_type), allocatable, target :: wwrk(:) type(psb_c_vect_type), pointer :: ww, q, r, p, v,& & s, z, f, rt, qt, uv - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,int_err(5),& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col,istop_, itx, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: np, me, ictxt integer(psb_ipk_) :: debug_level, debug_unit complex(psb_spk_) :: alpha, beta, rho, rho_old, sigma @@ -155,8 +156,8 @@ Subroutine psb_ccgs_vect(a,prec,b,x,eps,desc_a,info,& istop_ = 2 Endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) - if (info == psb_success_) call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) + if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_ccgstab.f90 b/krylov/psb_ccgstab.f90 index 9cbc3f90b..c8c1709c1 100644 --- a/krylov/psb_ccgstab.f90 +++ b/krylov/psb_ccgstab.f90 @@ -113,8 +113,9 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist complex(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) type(psb_c_vect_type) :: q, r, p, v, s, t, z, f - integer(psb_ipk_) :: itmax_, naux, mglob, it,itrace_,& + integer(psb_ipk_) :: itmax_, naux, it,itrace_,& & n_row, n_col + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. integer(psb_ipk_), Parameter :: irmax = 8 @@ -165,13 +166,13 @@ Subroutine psb_ccgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist ! = write(0,*) 'Warning: different dynamic types for X and B ' ! = end if - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_ccgstabl.f90 b/krylov/psb_ccgstabl.f90 index 8ab0453ac..cbad3d915 100644 --- a/krylov/psb_ccgstabl.f90 +++ b/krylov/psb_ccgstabl.f90 @@ -127,11 +127,12 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,& type(psb_c_vect_type), Pointer :: ww, q, r, rt0, p, v, & & s, t, z, f - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col, nl, err_act + integer(psb_lpk_) :: mglob Logical, Parameter :: exchange=.True., noexchange=.False. integer(psb_ipk_), Parameter :: irmax = 8 - integer(psb_ipk_) :: itx, i, istop_,j, k, int_err(5) + integer(psb_ipk_) :: itx, i, istop_,j, k integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: ictxt, np, me complex(psb_spk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& @@ -198,14 +199,13 @@ Subroutine psb_ccgstabl_vect(a,prec,b,x,eps,desc_a,info,& endif if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) - if (info == psb_success_) call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) + if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_cfcg.F90 b/krylov/psb_cfcg.F90 index 1f2d895d8..0b380f8f9 100644 --- a/krylov/psb_cfcg.F90 +++ b/krylov/psb_cfcg.F90 @@ -125,7 +125,8 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,& complex(psb_spk_) :: alpha, beta, delta, gamma, theta real(psb_dpk_) :: derr integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_ - integer(psb_ipk_) :: n_col, mglob, naux, err_act + integer(psb_ipk_) :: n_col, naux, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt complex(psb_spk_), allocatable, target :: aux(:) @@ -165,9 +166,9 @@ subroutine psb_cfcg_vect(a,prec,b,x,eps,desc_a,info,& endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_cgcr.f90 b/krylov/psb_cgcr.f90 index 1ce78fc38..a59b15a1e 100644 --- a/krylov/psb_cgcr.f90 +++ b/krylov/psb_cgcr.f90 @@ -130,7 +130,8 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,& type(psb_c_vect_type) :: r real(psb_dpk_) :: r_norm, b_norm, a_norm, derr - integer(psb_ipk_) :: n_col, mglob, naux, err_act + integer(psb_ipk_) :: n_col, naux, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst @@ -139,7 +140,6 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,& character(len=20) :: name type(psb_itconv_type) :: stopdat character(len=*), parameter :: methdname='GCR' - integer(psb_ipk_) ::int_err(5) info = psb_success_ name = 'psb_cgcr' call psb_erractionsave(err_act) @@ -176,16 +176,15 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err(1)=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') @@ -218,9 +217,8 @@ subroutine psb_cgcr_vect(a,prec,b,x,eps,desc_a,info,& if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif diff --git a/krylov/psb_crgmres.f90 b/krylov/psb_crgmres.f90 index f68dc74b6..7f81791ef 100644 --- a/krylov/psb_crgmres.f90 +++ b/krylov/psb_crgmres.f90 @@ -130,8 +130,9 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,& type(psb_c_vect_type) :: w, w1, xt real(psb_spk_) :: tmp complex(psb_spk_) :: scal, gm, rti, rti1 - integer(psb_ipk_) ::litmax, naux, mglob, it,k, itrace_,& - & n_row, n_col, nl, int_err(5) + integer(psb_ipk_) ::litmax, naux, it, k, itrace_,& + & n_row, n_col, nl + integer(psb_lpk_) :: mglob Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true. integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_, err_act @@ -179,9 +180,8 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err(1)=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif @@ -210,19 +210,18 @@ subroutine psb_crgmres_vect(a,prec,b,x,eps,desc_a,info,& endif if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_d_krylov_conv_mod.f90 b/krylov/psb_d_krylov_conv_mod.f90 index d77197a5a..d275bdbca 100644 --- a/krylov/psb_d_krylov_conv_mod.f90 +++ b/krylov/psb_d_krylov_conv_mod.f90 @@ -61,7 +61,7 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act, ierr(5) + integer(psb_ipk_) :: ictxt, me, np, err_act character(len=20) :: name real(psb_dpk_), allocatable :: r(:) @@ -98,8 +98,7 @@ contains call psb_gefree(r,desc_a,info) case default info=psb_err_invalid_istop_ - ierr(1) = stopc - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/stopc/)) goto 9999 end select if (info /= psb_success_) then @@ -213,7 +212,7 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act, ierr(5) + integer(psb_ipk_) :: ictxt, me, np, err_act character(len=20) :: name type(psb_d_vect_type) :: r @@ -250,8 +249,7 @@ contains call psb_gefree(r,desc_a,info) case default info=psb_err_invalid_istop_ - ierr(1) = stopc - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/stopc/)) goto 9999 end select if (info /= psb_success_) then diff --git a/krylov/psb_dbicg.f90 b/krylov/psb_dbicg.f90 index be2ed48f4..abea8b860 100644 --- a/krylov/psb_dbicg.f90 +++ b/krylov/psb_dbicg.f90 @@ -116,9 +116,9 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,& type(psb_d_vect_type), allocatable, target :: wwrk(:) type(psb_d_vect_type), pointer :: ww, q, r, p,& & zt, pt, z, rt, qt - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col, istop_, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit logical, parameter :: exchange=.true., noexchange=.false. integer(psb_ipk_), parameter :: irmax = 8 @@ -168,19 +168,18 @@ subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_dcg.F90 b/krylov/psb_dcg.F90 index 74d41d69d..dcccbd392 100644 --- a/krylov/psb_dcg.F90 +++ b/krylov/psb_dcg.F90 @@ -114,12 +114,13 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,& Real(psb_dpk_), Optional, Intent(out) :: err,cond ! = Local data real(psb_dpk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:) - integer(psb_mpik_), allocatable :: ibl(:), ispl(:), iwrk(:) + integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:) type(psb_d_vect_type), allocatable, target :: wwrk(:) type(psb_d_vect_type), pointer :: q, p, r, z, w real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old - integer(psb_ipk_) :: itmax_, istop_, naux, mglob, it, itx, itrace_,& - & n_col, n_row,err_act, int_err(5), ieg,nspl, istebz + integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,& + & n_col, n_row,err_act, ieg,nspl, istebz + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt real(psb_dpk_) :: derr @@ -160,9 +161,9 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,& istop_ = 2 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') @@ -298,7 +299,7 @@ subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,& & ieg,nspl,eig,ibl,ispl,ewrk,iwrk,info) if (info < 0) then call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='dstebz',i_err=(/info,izero,izero,izero,izero/)) + & a_err='dstebz',i_err=(/info/)) info=psb_err_from_subroutine_ai_ goto 9999 end if diff --git a/krylov/psb_dcgs.f90 b/krylov/psb_dcgs.f90 index dca1748b8..0545483d5 100644 --- a/krylov/psb_dcgs.f90 +++ b/krylov/psb_dcgs.f90 @@ -114,8 +114,9 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,& type(psb_d_vect_type), allocatable, target :: wwrk(:) type(psb_d_vect_type), pointer :: ww, q, r, p, v,& & s, z, f, rt, qt, uv - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,int_err(5),& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col,istop_, itx, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: np, me, ictxt integer(psb_ipk_) :: debug_level, debug_unit real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma @@ -155,8 +156,8 @@ Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,& istop_ = 2 Endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) - if (info == psb_success_) call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) + if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_dcgstab.f90 b/krylov/psb_dcgstab.f90 index 73b0662d1..449e5511f 100644 --- a/krylov/psb_dcgstab.f90 +++ b/krylov/psb_dcgstab.f90 @@ -113,8 +113,9 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:) type(psb_d_vect_type) :: q, r, p, v, s, t, z, f - integer(psb_ipk_) :: itmax_, naux, mglob, it,itrace_,& + integer(psb_ipk_) :: itmax_, naux, it,itrace_,& & n_row, n_col + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. integer(psb_ipk_), Parameter :: irmax = 8 @@ -165,13 +166,13 @@ Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist ! = write(0,*) 'Warning: different dynamic types for X and B ' ! = end if - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_dcgstabl.f90 b/krylov/psb_dcgstabl.f90 index c85f562b2..ef57df921 100644 --- a/krylov/psb_dcgstabl.f90 +++ b/krylov/psb_dcgstabl.f90 @@ -127,11 +127,12 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,& type(psb_d_vect_type), Pointer :: ww, q, r, rt0, p, v, & & s, t, z, f - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col, nl, err_act + integer(psb_lpk_) :: mglob Logical, Parameter :: exchange=.True., noexchange=.False. integer(psb_ipk_), Parameter :: irmax = 8 - integer(psb_ipk_) :: itx, i, istop_,j, k, int_err(5) + integer(psb_ipk_) :: itx, i, istop_,j, k integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: ictxt, np, me real(psb_dpk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& @@ -198,14 +199,13 @@ Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,& endif if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) - if (info == psb_success_) call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) + if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_dfcg.F90 b/krylov/psb_dfcg.F90 index bdb336d5b..6c856b4c0 100644 --- a/krylov/psb_dfcg.F90 +++ b/krylov/psb_dfcg.F90 @@ -125,7 +125,8 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,& real(psb_dpk_) :: alpha, beta, delta, gamma, theta real(psb_dpk_) :: derr integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_ - integer(psb_ipk_) :: n_col, mglob, naux, err_act + integer(psb_ipk_) :: n_col, naux, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt real(psb_dpk_), allocatable, target :: aux(:) @@ -165,9 +166,9 @@ subroutine psb_dfcg_vect(a,prec,b,x,eps,desc_a,info,& endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_dgcr.f90 b/krylov/psb_dgcr.f90 index acbaa5a73..59c5e2431 100644 --- a/krylov/psb_dgcr.f90 +++ b/krylov/psb_dgcr.f90 @@ -130,7 +130,8 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,& type(psb_d_vect_type) :: r real(psb_dpk_) :: r_norm, b_norm, a_norm, derr - integer(psb_ipk_) :: n_col, mglob, naux, err_act + integer(psb_ipk_) :: n_col, naux, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst @@ -139,7 +140,6 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,& character(len=20) :: name type(psb_itconv_type) :: stopdat character(len=*), parameter :: methdname='GCR' - integer(psb_ipk_) ::int_err(5) info = psb_success_ name = 'psb_dgcr' call psb_erractionsave(err_act) @@ -176,16 +176,15 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err(1)=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') @@ -218,9 +217,8 @@ subroutine psb_dgcr_vect(a,prec,b,x,eps,desc_a,info,& if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif diff --git a/krylov/psb_drgmres.f90 b/krylov/psb_drgmres.f90 index 9b5779034..da997427f 100644 --- a/krylov/psb_drgmres.f90 +++ b/krylov/psb_drgmres.f90 @@ -130,8 +130,9 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,& type(psb_d_vect_type) :: w, w1, xt real(psb_dpk_) :: tmp real(psb_dpk_) :: scal, gm, rti, rti1 - integer(psb_ipk_) ::litmax, naux, mglob, it,k, itrace_,& - & n_row, n_col, nl, int_err(5) + integer(psb_ipk_) ::litmax, naux, it, k, itrace_,& + & n_row, n_col, nl + integer(psb_lpk_) :: mglob Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true. integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_, err_act @@ -179,9 +180,8 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err(1)=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif @@ -210,19 +210,18 @@ subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,& endif if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_s_krylov_conv_mod.f90 b/krylov/psb_s_krylov_conv_mod.f90 index 4c5b0a07d..ede2eb757 100644 --- a/krylov/psb_s_krylov_conv_mod.f90 +++ b/krylov/psb_s_krylov_conv_mod.f90 @@ -61,7 +61,7 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act, ierr(5) + integer(psb_ipk_) :: ictxt, me, np, err_act character(len=20) :: name real(psb_spk_), allocatable :: r(:) @@ -98,8 +98,7 @@ contains call psb_gefree(r,desc_a,info) case default info=psb_err_invalid_istop_ - ierr(1) = stopc - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/stopc/)) goto 9999 end select if (info /= psb_success_) then @@ -213,7 +212,7 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act, ierr(5) + integer(psb_ipk_) :: ictxt, me, np, err_act character(len=20) :: name type(psb_s_vect_type) :: r @@ -250,8 +249,7 @@ contains call psb_gefree(r,desc_a,info) case default info=psb_err_invalid_istop_ - ierr(1) = stopc - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/stopc/)) goto 9999 end select if (info /= psb_success_) then diff --git a/krylov/psb_sbicg.f90 b/krylov/psb_sbicg.f90 index 2afaa7160..f5f543870 100644 --- a/krylov/psb_sbicg.f90 +++ b/krylov/psb_sbicg.f90 @@ -116,9 +116,9 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,& type(psb_s_vect_type), allocatable, target :: wwrk(:) type(psb_s_vect_type), pointer :: ww, q, r, p,& & zt, pt, z, rt, qt - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col, istop_, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit logical, parameter :: exchange=.true., noexchange=.false. integer(psb_ipk_), parameter :: irmax = 8 @@ -168,19 +168,18 @@ subroutine psb_sbicg_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_scg.F90 b/krylov/psb_scg.F90 index 92241791c..c85520c0f 100644 --- a/krylov/psb_scg.F90 +++ b/krylov/psb_scg.F90 @@ -114,12 +114,13 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,& Real(psb_spk_), Optional, Intent(out) :: err,cond ! = Local data real(psb_spk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:) - integer(psb_mpik_), allocatable :: ibl(:), ispl(:), iwrk(:) + integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:) type(psb_s_vect_type), allocatable, target :: wwrk(:) type(psb_s_vect_type), pointer :: q, p, r, z, w real(psb_spk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old - integer(psb_ipk_) :: itmax_, istop_, naux, mglob, it, itx, itrace_,& - & n_col, n_row,err_act, int_err(5), ieg,nspl, istebz + integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,& + & n_col, n_row,err_act, ieg,nspl, istebz + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt real(psb_dpk_) :: derr @@ -160,9 +161,9 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,& istop_ = 2 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') @@ -298,7 +299,7 @@ subroutine psb_scg_vect(a,prec,b,x,eps,desc_a,info,& & ieg,nspl,eig,ibl,ispl,ewrk,iwrk,info) if (info < 0) then call psb_errpush(psb_err_from_subroutine_ai_,name,& - & a_err='sstebz',i_err=(/info,izero,izero,izero,izero/)) + & a_err='sstebz',i_err=(/info/)) info=psb_err_from_subroutine_ai_ goto 9999 end if diff --git a/krylov/psb_scgs.f90 b/krylov/psb_scgs.f90 index d053444a4..b45d6b9d4 100644 --- a/krylov/psb_scgs.f90 +++ b/krylov/psb_scgs.f90 @@ -114,8 +114,9 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,& type(psb_s_vect_type), allocatable, target :: wwrk(:) type(psb_s_vect_type), pointer :: ww, q, r, p, v,& & s, z, f, rt, qt, uv - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,int_err(5),& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col,istop_, itx, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: np, me, ictxt integer(psb_ipk_) :: debug_level, debug_unit real(psb_spk_) :: alpha, beta, rho, rho_old, sigma @@ -155,8 +156,8 @@ Subroutine psb_scgs_vect(a,prec,b,x,eps,desc_a,info,& istop_ = 2 Endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) - if (info == psb_success_) call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) + if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_scgstab.f90 b/krylov/psb_scgstab.f90 index c0ca345cc..62eb965ad 100644 --- a/krylov/psb_scgstab.f90 +++ b/krylov/psb_scgstab.f90 @@ -113,8 +113,9 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist real(psb_spk_), allocatable, target :: aux(:),wwrk(:,:) type(psb_s_vect_type) :: q, r, p, v, s, t, z, f - integer(psb_ipk_) :: itmax_, naux, mglob, it,itrace_,& + integer(psb_ipk_) :: itmax_, naux, it,itrace_,& & n_row, n_col + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. integer(psb_ipk_), Parameter :: irmax = 8 @@ -165,13 +166,13 @@ Subroutine psb_scgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist ! = write(0,*) 'Warning: different dynamic types for X and B ' ! = end if - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_scgstabl.f90 b/krylov/psb_scgstabl.f90 index 0f888980c..82cbadc7e 100644 --- a/krylov/psb_scgstabl.f90 +++ b/krylov/psb_scgstabl.f90 @@ -127,11 +127,12 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,& type(psb_s_vect_type), Pointer :: ww, q, r, rt0, p, v, & & s, t, z, f - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col, nl, err_act + integer(psb_lpk_) :: mglob Logical, Parameter :: exchange=.True., noexchange=.False. integer(psb_ipk_), Parameter :: irmax = 8 - integer(psb_ipk_) :: itx, i, istop_,j, k, int_err(5) + integer(psb_ipk_) :: itx, i, istop_,j, k integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: ictxt, np, me real(psb_spk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& @@ -198,14 +199,13 @@ Subroutine psb_scgstabl_vect(a,prec,b,x,eps,desc_a,info,& endif if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) - if (info == psb_success_) call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) + if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_sfcg.F90 b/krylov/psb_sfcg.F90 index 5b4e69573..9337f487a 100644 --- a/krylov/psb_sfcg.F90 +++ b/krylov/psb_sfcg.F90 @@ -125,7 +125,8 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,& real(psb_spk_) :: alpha, beta, delta, gamma, theta real(psb_dpk_) :: derr integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_ - integer(psb_ipk_) :: n_col, mglob, naux, err_act + integer(psb_ipk_) :: n_col, naux, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt real(psb_spk_), allocatable, target :: aux(:) @@ -165,9 +166,9 @@ subroutine psb_sfcg_vect(a,prec,b,x,eps,desc_a,info,& endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_sgcr.f90 b/krylov/psb_sgcr.f90 index 08333af28..ce11c3897 100644 --- a/krylov/psb_sgcr.f90 +++ b/krylov/psb_sgcr.f90 @@ -130,7 +130,8 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,& type(psb_s_vect_type) :: r real(psb_dpk_) :: r_norm, b_norm, a_norm, derr - integer(psb_ipk_) :: n_col, mglob, naux, err_act + integer(psb_ipk_) :: n_col, naux, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst @@ -139,7 +140,6 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,& character(len=20) :: name type(psb_itconv_type) :: stopdat character(len=*), parameter :: methdname='GCR' - integer(psb_ipk_) ::int_err(5) info = psb_success_ name = 'psb_sgcr' call psb_erractionsave(err_act) @@ -176,16 +176,15 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err(1)=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') @@ -218,9 +217,8 @@ subroutine psb_sgcr_vect(a,prec,b,x,eps,desc_a,info,& if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif diff --git a/krylov/psb_srgmres.f90 b/krylov/psb_srgmres.f90 index 2e458d82a..a2713716e 100644 --- a/krylov/psb_srgmres.f90 +++ b/krylov/psb_srgmres.f90 @@ -130,8 +130,9 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,& type(psb_s_vect_type) :: w, w1, xt real(psb_spk_) :: tmp real(psb_spk_) :: scal, gm, rti, rti1 - integer(psb_ipk_) ::litmax, naux, mglob, it,k, itrace_,& - & n_row, n_col, nl, int_err(5) + integer(psb_ipk_) ::litmax, naux, it, k, itrace_,& + & n_row, n_col, nl + integer(psb_lpk_) :: mglob Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true. integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_, err_act @@ -179,9 +180,8 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err(1)=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif @@ -210,19 +210,18 @@ subroutine psb_srgmres_vect(a,prec,b,x,eps,desc_a,info,& endif if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_z_krylov_conv_mod.f90 b/krylov/psb_z_krylov_conv_mod.f90 index 5e300cbb6..333dd031b 100644 --- a/krylov/psb_z_krylov_conv_mod.f90 +++ b/krylov/psb_z_krylov_conv_mod.f90 @@ -61,7 +61,7 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act, ierr(5) + integer(psb_ipk_) :: ictxt, me, np, err_act character(len=20) :: name complex(psb_dpk_), allocatable :: r(:) @@ -98,8 +98,7 @@ contains call psb_gefree(r,desc_a,info) case default info=psb_err_invalid_istop_ - ierr(1) = stopc - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/stopc/)) goto 9999 end select if (info /= psb_success_) then @@ -213,7 +212,7 @@ contains type(psb_itconv_type) :: stopdat integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: ictxt, me, np, err_act, ierr(5) + integer(psb_ipk_) :: ictxt, me, np, err_act character(len=20) :: name type(psb_z_vect_type) :: r @@ -250,8 +249,7 @@ contains call psb_gefree(r,desc_a,info) case default info=psb_err_invalid_istop_ - ierr(1) = stopc - call psb_errpush(info,name,i_err=ierr) + call psb_errpush(info,name,i_err=(/stopc/)) goto 9999 end select if (info /= psb_success_) then diff --git a/krylov/psb_zbicg.f90 b/krylov/psb_zbicg.f90 index 969280d39..d216c93c8 100644 --- a/krylov/psb_zbicg.f90 +++ b/krylov/psb_zbicg.f90 @@ -116,9 +116,9 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,& type(psb_z_vect_type), allocatable, target :: wwrk(:) type(psb_z_vect_type), pointer :: ww, q, r, p,& & zt, pt, z, rt, qt - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col, istop_, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit logical, parameter :: exchange=.true., noexchange=.false. integer(psb_ipk_), parameter :: irmax = 8 @@ -168,19 +168,18 @@ subroutine psb_zbicg_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_zcg.F90 b/krylov/psb_zcg.F90 index 691a0f08e..a5616e85d 100644 --- a/krylov/psb_zcg.F90 +++ b/krylov/psb_zcg.F90 @@ -114,12 +114,13 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,& Real(psb_dpk_), Optional, Intent(out) :: err,cond ! = Local data complex(psb_dpk_), allocatable, target :: aux(:),td(:),tu(:),eig(:),ewrk(:) - integer(psb_mpik_), allocatable :: ibl(:), ispl(:), iwrk(:) + integer(psb_mpk_), allocatable :: ibl(:), ispl(:), iwrk(:) type(psb_z_vect_type), allocatable, target :: wwrk(:) type(psb_z_vect_type), pointer :: q, p, r, z, w complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old - integer(psb_ipk_) :: itmax_, istop_, naux, mglob, it, itx, itrace_,& - & n_col, n_row,err_act, int_err(5), ieg,nspl, istebz + integer(psb_ipk_) :: itmax_, istop_, naux, it, itx, itrace_,& + & n_col, n_row,err_act, ieg,nspl, istebz + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt real(psb_dpk_) :: derr @@ -160,9 +161,9 @@ subroutine psb_zcg_vect(a,prec,b,x,eps,desc_a,info,& istop_ = 2 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_zcgs.f90 b/krylov/psb_zcgs.f90 index 3130427ad..c40914282 100644 --- a/krylov/psb_zcgs.f90 +++ b/krylov/psb_zcgs.f90 @@ -114,8 +114,9 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,& type(psb_z_vect_type), allocatable, target :: wwrk(:) type(psb_z_vect_type), pointer :: ww, q, r, p, v,& & s, z, f, rt, qt, uv - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,int_err(5),& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col,istop_, itx, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: np, me, ictxt integer(psb_ipk_) :: debug_level, debug_unit complex(psb_dpk_) :: alpha, beta, rho, rho_old, sigma @@ -155,8 +156,8 @@ Subroutine psb_zcgs_vect(a,prec,b,x,eps,desc_a,info,& istop_ = 2 Endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) - if (info == psb_success_) call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) + if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_zcgstab.f90 b/krylov/psb_zcgstab.f90 index 68381c482..4fca5c038 100644 --- a/krylov/psb_zcgstab.f90 +++ b/krylov/psb_zcgstab.f90 @@ -113,8 +113,9 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist complex(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:) type(psb_z_vect_type) :: q, r, p, v, s, t, z, f - integer(psb_ipk_) :: itmax_, naux, mglob, it,itrace_,& + integer(psb_ipk_) :: itmax_, naux, it,itrace_,& & n_row, n_col + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. integer(psb_ipk_), Parameter :: irmax = 8 @@ -165,13 +166,13 @@ Subroutine psb_zcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,ist ! = write(0,*) 'Warning: different dynamic types for X and B ' ! = end if - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if (psb_errstatus_fatal()) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/krylov/psb_zcgstabl.f90 b/krylov/psb_zcgstabl.f90 index 5ddbf3092..e2519fea2 100644 --- a/krylov/psb_zcgstabl.f90 +++ b/krylov/psb_zcgstabl.f90 @@ -127,11 +127,12 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,& type(psb_z_vect_type), Pointer :: ww, q, r, rt0, p, v, & & s, t, z, f - integer(psb_ipk_) :: itmax_, naux, mglob, it, itrace_,& + integer(psb_ipk_) :: itmax_, naux, it, itrace_,& & n_row, n_col, nl, err_act + integer(psb_lpk_) :: mglob Logical, Parameter :: exchange=.True., noexchange=.False. integer(psb_ipk_), Parameter :: irmax = 8 - integer(psb_ipk_) :: itx, i, istop_,j, k, int_err(5) + integer(psb_ipk_) :: itx, i, istop_,j, k integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: ictxt, np, me complex(psb_dpk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& @@ -198,14 +199,13 @@ Subroutine psb_zcgstabl_vect(a,prec,b,x,eps,desc_a,info,& endif if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) - if (info == psb_success_) call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) + if (info == psb_success_) call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_zfcg.F90 b/krylov/psb_zfcg.F90 index cb9289bd0..cf5854aaa 100644 --- a/krylov/psb_zfcg.F90 +++ b/krylov/psb_zfcg.F90 @@ -125,7 +125,8 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,& complex(psb_dpk_) :: alpha, beta, delta, gamma, theta real(psb_dpk_) :: derr integer(psb_ipk_) :: i, idx, nc2l, it, itx, istop_, itmax_, itrace_ - integer(psb_ipk_) :: n_col, mglob, naux, err_act + integer(psb_ipk_) :: n_col, naux, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt complex(psb_dpk_), allocatable, target :: aux(:) @@ -165,9 +166,9 @@ subroutine psb_zfcg_vect(a,prec,b,x,eps,desc_a,info,& endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') diff --git a/krylov/psb_zgcr.f90 b/krylov/psb_zgcr.f90 index 40b4cf7fe..c40f21667 100644 --- a/krylov/psb_zgcr.f90 +++ b/krylov/psb_zgcr.f90 @@ -130,7 +130,8 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,& type(psb_z_vect_type) :: r real(psb_dpk_) :: r_norm, b_norm, a_norm, derr - integer(psb_ipk_) :: n_col, mglob, naux, err_act + integer(psb_ipk_) :: n_col, naux, err_act + integer(psb_lpk_) :: mglob integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: np, me, ictxt integer(psb_ipk_) :: i, j, it, itx, istop_, itmax_, itrace_, nl, m, nrst @@ -139,7 +140,6 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,& character(len=20) :: name type(psb_itconv_type) :: stopdat character(len=*), parameter :: methdname='GCR' - integer(psb_ipk_) ::int_err(5) info = psb_success_ name = 'psb_zgcr' call psb_erractionsave(err_act) @@ -176,16 +176,15 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err(1)=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if (info == psb_success_)& - & call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + & call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X/B') @@ -218,9 +217,8 @@ subroutine psb_zgcr_vect(a,prec,b,x,eps,desc_a,info,& if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif diff --git a/krylov/psb_zrgmres.f90 b/krylov/psb_zrgmres.f90 index 107386993..5ba3ab24d 100644 --- a/krylov/psb_zrgmres.f90 +++ b/krylov/psb_zrgmres.f90 @@ -130,8 +130,9 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,& type(psb_z_vect_type) :: w, w1, xt real(psb_dpk_) :: tmp complex(psb_dpk_) :: scal, gm, rti, rti1 - integer(psb_ipk_) ::litmax, naux, mglob, it,k, itrace_,& - & n_row, n_col, nl, int_err(5) + integer(psb_ipk_) ::litmax, naux, it, k, itrace_,& + & n_row, n_col, nl + integer(psb_lpk_) :: mglob Logical, Parameter :: exchange=.True., noexchange=.False., use_srot=.true. integer(psb_ipk_), Parameter :: irmax = 8 integer(psb_ipk_) :: itx, i, istop_, err_act @@ -179,9 +180,8 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,& if ((istop_ < 1 ).or.(istop_ > 2 ) ) then info=psb_err_invalid_istop_ - int_err(1)=istop_ err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/istop_/)) goto 9999 endif @@ -210,19 +210,18 @@ subroutine psb_zrgmres_vect(a,prec,b,x,eps,desc_a,info,& endif if (nl <=0 ) then info=psb_err_invalid_istop_ - int_err(1)=nl err=info - call psb_errpush(info,name,i_err=int_err) + call psb_errpush(info,name,i_err=(/nl/)) goto 9999 endif - call psb_chkvect(mglob,ione,x%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,x%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on X') goto 9999 end if - call psb_chkvect(mglob,ione,b%get_nrows(),ione,ione,desc_a,info) + call psb_chkvect(mglob,lone,b%get_nrows(),lone,lone,desc_a,info) if(info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='psb_chkvect on B') diff --git a/notes.txt b/notes.txt new file mode 100644 index 000000000..808f3eda2 --- /dev/null +++ b/notes.txt @@ -0,0 +1,32 @@ +1. Perhaps we should switch completely to external indices being of + kind LPK and internal indices being of type IPK, and the two morph + independently in int32/int64 (although admittedly LPK=32 and IPK=64 + does not make much sense) + +2. Change sizeof_ constant names accordingly to sizeof_ipk and + sizeof_lpk. + +3. Should we define a psb_l_vect_type? But then, if I==L how can we + distinguish? Answer: if I==L the two vect type are still considered + different, even when internally they are the same. + +4. So, let's rewrite under these rules: + psb_mpk_: Always 32 bits, used for MPI related stuff. + psb_ipk_: Can be 32 or 64 bits, always used for "local" indices and + sizes + psb_lpk_: Can be 32 or 64 bits, always used for "global" indices + and sizes, must be psb_lpk_ >= psb_ipk_ + psb_epk_: always 64 bits, used for SIZEOF & friends. + +5. Let's define the SND/RCV/SUM/MAX & friends in terms of M and E, the + compiler will remap I and L onto them automatically + +6. Similar for sort; except for the inner routines of heap, where we + provide heap types I_IDX_HEAP, they have to be written + independently beccause the encapsulated types are always + different. + +7. For communication stuff: let us define psb_i_base_vect and + psb_l_base_vect; the communication routines will work in terms of + them, then remap onto the array routines, which are going to be + written in terms of E and M. diff --git a/prec/impl/psb_c_bjacprec_impl.f90 b/prec/impl/psb_c_bjacprec_impl.f90 index f8ecdf04c..c1e24f42b 100644 --- a/prec/impl/psb_c_bjacprec_impl.f90 +++ b/prec/impl/psb_c_bjacprec_impl.f90 @@ -434,10 +434,12 @@ subroutine psb_c_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) character(len=20) :: ch_err - if(psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_ctxt() call prec%set_ctxt(ictxt) diff --git a/prec/impl/psb_cprecbld.f90 b/prec/impl/psb_cprecbld.f90 index 4457a1992..588ac84d4 100644 --- a/prec/impl/psb_cprecbld.f90 +++ b/prec/impl/psb_cprecbld.f90 @@ -46,19 +46,18 @@ subroutine psb_cprecbld(a,desc_a,p,info,amold,vmold,imold) ! Local scalars integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: err, n_row, n_col,mglob, err_act - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_),parameter :: iroot=psb_root_,iout=60,ilout=40 character(len=20) :: name, ch_err - if(psb_get_errstatus() /= 0) return info=psb_success_ err=0 - call psb_erractionsave(err_act) name = 'psb_precbld' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info = psb_success_ - int_err(1) = 0 ictxt = desc_a%get_context() call psb_info(ictxt, me, np) diff --git a/prec/impl/psb_d_bjacprec_impl.f90 b/prec/impl/psb_d_bjacprec_impl.f90 index 6ac52d978..8420da459 100644 --- a/prec/impl/psb_d_bjacprec_impl.f90 +++ b/prec/impl/psb_d_bjacprec_impl.f90 @@ -434,10 +434,12 @@ subroutine psb_d_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) character(len=20) :: ch_err - if(psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_ctxt() call prec%set_ctxt(ictxt) diff --git a/prec/impl/psb_dprecbld.f90 b/prec/impl/psb_dprecbld.f90 index 8027c8daf..dc3d75859 100644 --- a/prec/impl/psb_dprecbld.f90 +++ b/prec/impl/psb_dprecbld.f90 @@ -46,19 +46,18 @@ subroutine psb_dprecbld(a,desc_a,p,info,amold,vmold,imold) ! Local scalars integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: err, n_row, n_col,mglob, err_act - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_),parameter :: iroot=psb_root_,iout=60,ilout=40 character(len=20) :: name, ch_err - if(psb_get_errstatus() /= 0) return info=psb_success_ err=0 - call psb_erractionsave(err_act) name = 'psb_precbld' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info = psb_success_ - int_err(1) = 0 ictxt = desc_a%get_context() call psb_info(ictxt, me, np) diff --git a/prec/impl/psb_s_bjacprec_impl.f90 b/prec/impl/psb_s_bjacprec_impl.f90 index 528224c0a..eecf85d14 100644 --- a/prec/impl/psb_s_bjacprec_impl.f90 +++ b/prec/impl/psb_s_bjacprec_impl.f90 @@ -434,10 +434,12 @@ subroutine psb_s_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) character(len=20) :: ch_err - if(psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_ctxt() call prec%set_ctxt(ictxt) diff --git a/prec/impl/psb_sprecbld.f90 b/prec/impl/psb_sprecbld.f90 index 328d9f01e..8cc48eaba 100644 --- a/prec/impl/psb_sprecbld.f90 +++ b/prec/impl/psb_sprecbld.f90 @@ -46,19 +46,18 @@ subroutine psb_sprecbld(a,desc_a,p,info,amold,vmold,imold) ! Local scalars integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: err, n_row, n_col,mglob, err_act - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_),parameter :: iroot=psb_root_,iout=60,ilout=40 character(len=20) :: name, ch_err - if(psb_get_errstatus() /= 0) return info=psb_success_ err=0 - call psb_erractionsave(err_act) name = 'psb_precbld' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info = psb_success_ - int_err(1) = 0 ictxt = desc_a%get_context() call psb_info(ictxt, me, np) diff --git a/prec/impl/psb_z_bjacprec_impl.f90 b/prec/impl/psb_z_bjacprec_impl.f90 index ac55d8622..57825bf4b 100644 --- a/prec/impl/psb_z_bjacprec_impl.f90 +++ b/prec/impl/psb_z_bjacprec_impl.f90 @@ -434,10 +434,12 @@ subroutine psb_z_bjac_precbld(a,desc_a,prec,info,amold,vmold,imold) character(len=20) :: ch_err - if(psb_get_errstatus() /= 0) return info = psb_success_ call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if ictxt=desc_a%get_ctxt() call prec%set_ctxt(ictxt) diff --git a/prec/impl/psb_zprecbld.f90 b/prec/impl/psb_zprecbld.f90 index 4f6559cf5..b99cfe929 100644 --- a/prec/impl/psb_zprecbld.f90 +++ b/prec/impl/psb_zprecbld.f90 @@ -46,19 +46,18 @@ subroutine psb_zprecbld(a,desc_a,p,info,amold,vmold,imold) ! Local scalars integer(psb_ipk_) :: ictxt, me,np integer(psb_ipk_) :: err, n_row, n_col,mglob, err_act - integer(psb_ipk_) :: int_err(5) - integer(psb_ipk_),parameter :: iroot=psb_root_,iout=60,ilout=40 character(len=20) :: name, ch_err - if(psb_get_errstatus() /= 0) return info=psb_success_ err=0 - call psb_erractionsave(err_act) name = 'psb_precbld' + call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if info = psb_success_ - int_err(1) = 0 ictxt = desc_a%get_context() call psb_info(ictxt, me, np) diff --git a/prec/psb_c_base_prec_mod.f90 b/prec/psb_c_base_prec_mod.f90 index 9325f2ae6..9fe9d8e1d 100644 --- a/prec/psb_c_base_prec_mod.f90 +++ b/prec/psb_c_base_prec_mod.f90 @@ -36,10 +36,10 @@ module psb_c_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_spk_, psb_ipk_, psb_long_int_k_,& + use psb_base_mod, only : psb_spk_, psb_ipk_, psb_epk_,& & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& - & psb_sizeof_int, psb_sizeof_long_int, psb_sizeof_sp, psb_sizeof_dp, & - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus, psb_success_,& + & psb_sizeof_ip, psb_sizeof_lp, psb_sizeof_sp, psb_sizeof_dp, & + & psb_erractionsave, psb_erractionrestore, psb_error, psb_errstatus_fatal, psb_success_,& & psb_c_base_sparse_mat, psb_cspmat_type, psb_c_csr_sparse_mat,& & psb_c_base_vect_type, psb_c_vect_type, psb_i_base_vect_type @@ -269,7 +269,7 @@ contains function psb_c_base_sizeof(prec) result(val) class(psb_c_base_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 return @@ -285,7 +285,7 @@ contains function psb_c_base_get_nzeros(prec) result(res) class(psb_c_base_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 diff --git a/prec/psb_c_bjacprec.f90 b/prec/psb_c_bjacprec.f90 index d7be28e6f..7da40e38a 100644 --- a/prec/psb_c_bjacprec.f90 +++ b/prec/psb_c_bjacprec.f90 @@ -188,7 +188,7 @@ contains function psb_c_bjac_sizeof(prec) result(val) class(psb_c_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) then @@ -204,7 +204,7 @@ contains function psb_c_bjac_get_nzeros(prec) result(val) class(psb_c_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) then diff --git a/prec/psb_c_diagprec.f90 b/prec/psb_c_diagprec.f90 index c766f1e62..f2eaa4d08 100644 --- a/prec/psb_c_diagprec.f90 +++ b/prec/psb_c_diagprec.f90 @@ -212,7 +212,7 @@ contains function psb_c_diag_sizeof(prec) result(val) class(psb_c_diag_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = (2*psb_sizeof_sp) * prec%get_nzeros() return @@ -220,7 +220,7 @@ contains function psb_c_diag_get_nzeros(prec) result(val) class(psb_c_diag_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) val = val + prec%dv%get_nrows() diff --git a/prec/psb_c_nullprec.f90 b/prec/psb_c_nullprec.f90 index 5dabb2d46..9a75366e8 100644 --- a/prec/psb_c_nullprec.f90 +++ b/prec/psb_c_nullprec.f90 @@ -253,7 +253,7 @@ contains function psb_c_null_sizeof(prec) result(val) class(psb_c_null_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 diff --git a/prec/psb_c_prec_type.f90 b/prec/psb_c_prec_type.f90 index 06445102a..5e341e1cd 100644 --- a/prec/psb_c_prec_type.f90 +++ b/prec/psb_c_prec_type.f90 @@ -77,8 +77,8 @@ module psb_c_prec_type & psb_c_base_sparse_mat, psb_spk_, psb_c_base_vect_type, & & psb_cprec_type, psb_i_base_vect_type implicit none - type(psb_cspmat_type), intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a + type(psb_cspmat_type), intent(in), target :: a + type(psb_desc_type), intent(inout), target :: desc_a class(psb_cprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info class(psb_c_base_sparse_mat), intent(in), optional :: amold @@ -201,10 +201,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if me=-1 call p%free(info) @@ -226,10 +228,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if me=-1 @@ -250,7 +254,7 @@ contains function psb_cprec_sizeof(prec) result(val) class(psb_cprec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val integer(psb_ipk_) :: i val = 0 diff --git a/prec/psb_d_base_prec_mod.f90 b/prec/psb_d_base_prec_mod.f90 index 6acdf7fc0..738f65737 100644 --- a/prec/psb_d_base_prec_mod.f90 +++ b/prec/psb_d_base_prec_mod.f90 @@ -36,10 +36,10 @@ module psb_d_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_long_int_k_,& + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_epk_,& & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& - & psb_sizeof_int, psb_sizeof_long_int, psb_sizeof_sp, psb_sizeof_dp, & - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus, psb_success_,& + & psb_sizeof_ip, psb_sizeof_lp, psb_sizeof_sp, psb_sizeof_dp, & + & psb_erractionsave, psb_erractionrestore, psb_error, psb_errstatus_fatal, psb_success_,& & psb_d_base_sparse_mat, psb_dspmat_type, psb_d_csr_sparse_mat,& & psb_d_base_vect_type, psb_d_vect_type, psb_i_base_vect_type @@ -269,7 +269,7 @@ contains function psb_d_base_sizeof(prec) result(val) class(psb_d_base_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 return @@ -285,7 +285,7 @@ contains function psb_d_base_get_nzeros(prec) result(res) class(psb_d_base_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 diff --git a/prec/psb_d_bjacprec.f90 b/prec/psb_d_bjacprec.f90 index 8a79c84ed..3568af076 100644 --- a/prec/psb_d_bjacprec.f90 +++ b/prec/psb_d_bjacprec.f90 @@ -188,7 +188,7 @@ contains function psb_d_bjac_sizeof(prec) result(val) class(psb_d_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) then @@ -204,7 +204,7 @@ contains function psb_d_bjac_get_nzeros(prec) result(val) class(psb_d_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) then diff --git a/prec/psb_d_diagprec.f90 b/prec/psb_d_diagprec.f90 index 5b23077d4..4bdda8bcf 100644 --- a/prec/psb_d_diagprec.f90 +++ b/prec/psb_d_diagprec.f90 @@ -212,7 +212,7 @@ contains function psb_d_diag_sizeof(prec) result(val) class(psb_d_diag_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = psb_sizeof_dp * prec%get_nzeros() return @@ -220,7 +220,7 @@ contains function psb_d_diag_get_nzeros(prec) result(val) class(psb_d_diag_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) val = val + prec%dv%get_nrows() diff --git a/prec/psb_d_nullprec.f90 b/prec/psb_d_nullprec.f90 index e22edba91..421c59ef8 100644 --- a/prec/psb_d_nullprec.f90 +++ b/prec/psb_d_nullprec.f90 @@ -253,7 +253,7 @@ contains function psb_d_null_sizeof(prec) result(val) class(psb_d_null_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 diff --git a/prec/psb_d_prec_type.f90 b/prec/psb_d_prec_type.f90 index aeb314ae9..f420d2828 100644 --- a/prec/psb_d_prec_type.f90 +++ b/prec/psb_d_prec_type.f90 @@ -77,8 +77,8 @@ module psb_d_prec_type & psb_d_base_sparse_mat, psb_dpk_, psb_d_base_vect_type, & & psb_dprec_type, psb_i_base_vect_type implicit none - type(psb_dspmat_type), intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a + type(psb_dspmat_type), intent(in), target :: a + type(psb_desc_type), intent(inout), target :: desc_a class(psb_dprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info class(psb_d_base_sparse_mat), intent(in), optional :: amold @@ -201,10 +201,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if me=-1 call p%free(info) @@ -226,10 +228,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if me=-1 @@ -250,7 +254,7 @@ contains function psb_dprec_sizeof(prec) result(val) class(psb_dprec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val integer(psb_ipk_) :: i val = 0 diff --git a/prec/psb_prec_const_mod.f90 b/prec/psb_prec_const_mod.f90 index 34d5d5168..ffe77f162 100644 --- a/prec/psb_prec_const_mod.f90 +++ b/prec/psb_prec_const_mod.f90 @@ -35,7 +35,7 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module psb_prec_const_mod - use psb_base_mod, only : psb_dpk_, psb_spk_, psb_ipk_, psb_long_int_k_,& + use psb_base_mod, only : psb_dpk_, psb_spk_, psb_ipk_, psb_epk_,& & psb_err_unit, psb_inp_unit, psb_out_unit integer(psb_ipk_), parameter :: psb_min_prec_=0, psb_noprec_=0, psb_diag_=1, & diff --git a/prec/psb_s_base_prec_mod.f90 b/prec/psb_s_base_prec_mod.f90 index ccfd6e013..eb468301a 100644 --- a/prec/psb_s_base_prec_mod.f90 +++ b/prec/psb_s_base_prec_mod.f90 @@ -36,10 +36,10 @@ module psb_s_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_spk_, psb_ipk_, psb_long_int_k_,& + use psb_base_mod, only : psb_spk_, psb_ipk_, psb_epk_,& & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& - & psb_sizeof_int, psb_sizeof_long_int, psb_sizeof_sp, psb_sizeof_dp, & - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus, psb_success_,& + & psb_sizeof_ip, psb_sizeof_lp, psb_sizeof_sp, psb_sizeof_dp, & + & psb_erractionsave, psb_erractionrestore, psb_error, psb_errstatus_fatal, psb_success_,& & psb_s_base_sparse_mat, psb_sspmat_type, psb_s_csr_sparse_mat,& & psb_s_base_vect_type, psb_s_vect_type, psb_i_base_vect_type @@ -269,7 +269,7 @@ contains function psb_s_base_sizeof(prec) result(val) class(psb_s_base_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 return @@ -285,7 +285,7 @@ contains function psb_s_base_get_nzeros(prec) result(res) class(psb_s_base_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 diff --git a/prec/psb_s_bjacprec.f90 b/prec/psb_s_bjacprec.f90 index 269bb0eb5..093da0cae 100644 --- a/prec/psb_s_bjacprec.f90 +++ b/prec/psb_s_bjacprec.f90 @@ -188,7 +188,7 @@ contains function psb_s_bjac_sizeof(prec) result(val) class(psb_s_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) then @@ -204,7 +204,7 @@ contains function psb_s_bjac_get_nzeros(prec) result(val) class(psb_s_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) then diff --git a/prec/psb_s_diagprec.f90 b/prec/psb_s_diagprec.f90 index ecf46d56a..56c3c4582 100644 --- a/prec/psb_s_diagprec.f90 +++ b/prec/psb_s_diagprec.f90 @@ -212,7 +212,7 @@ contains function psb_s_diag_sizeof(prec) result(val) class(psb_s_diag_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = psb_sizeof_sp * prec%get_nzeros() return @@ -220,7 +220,7 @@ contains function psb_s_diag_get_nzeros(prec) result(val) class(psb_s_diag_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) val = val + prec%dv%get_nrows() diff --git a/prec/psb_s_nullprec.f90 b/prec/psb_s_nullprec.f90 index 93411f633..06e312510 100644 --- a/prec/psb_s_nullprec.f90 +++ b/prec/psb_s_nullprec.f90 @@ -253,7 +253,7 @@ contains function psb_s_null_sizeof(prec) result(val) class(psb_s_null_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 diff --git a/prec/psb_s_prec_type.f90 b/prec/psb_s_prec_type.f90 index e59844040..4eb157c6c 100644 --- a/prec/psb_s_prec_type.f90 +++ b/prec/psb_s_prec_type.f90 @@ -77,8 +77,8 @@ module psb_s_prec_type & psb_s_base_sparse_mat, psb_spk_, psb_s_base_vect_type, & & psb_sprec_type, psb_i_base_vect_type implicit none - type(psb_sspmat_type), intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a + type(psb_sspmat_type), intent(in), target :: a + type(psb_desc_type), intent(inout), target :: desc_a class(psb_sprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info class(psb_s_base_sparse_mat), intent(in), optional :: amold @@ -201,10 +201,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if me=-1 call p%free(info) @@ -226,10 +228,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if me=-1 @@ -250,7 +254,7 @@ contains function psb_sprec_sizeof(prec) result(val) class(psb_sprec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val integer(psb_ipk_) :: i val = 0 diff --git a/prec/psb_z_base_prec_mod.f90 b/prec/psb_z_base_prec_mod.f90 index fca3b5bdb..ad9eacc1c 100644 --- a/prec/psb_z_base_prec_mod.f90 +++ b/prec/psb_z_base_prec_mod.f90 @@ -36,10 +36,10 @@ module psb_z_base_prec_mod ! Reduces size of .mod file. - use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_long_int_k_,& + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_epk_,& & psb_desc_type, psb_sizeof, psb_free, psb_cdfree, psb_errpush, psb_act_abort_,& - & psb_sizeof_int, psb_sizeof_long_int, psb_sizeof_sp, psb_sizeof_dp, & - & psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus, psb_success_,& + & psb_sizeof_ip, psb_sizeof_lp, psb_sizeof_sp, psb_sizeof_dp, & + & psb_erractionsave, psb_erractionrestore, psb_error, psb_errstatus_fatal, psb_success_,& & psb_z_base_sparse_mat, psb_zspmat_type, psb_z_csr_sparse_mat,& & psb_z_base_vect_type, psb_z_vect_type, psb_i_base_vect_type @@ -269,7 +269,7 @@ contains function psb_z_base_sizeof(prec) result(val) class(psb_z_base_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 return @@ -285,7 +285,7 @@ contains function psb_z_base_get_nzeros(prec) result(res) class(psb_z_base_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 0 diff --git a/prec/psb_z_bjacprec.f90 b/prec/psb_z_bjacprec.f90 index cd5bf8890..d7b630d05 100644 --- a/prec/psb_z_bjacprec.f90 +++ b/prec/psb_z_bjacprec.f90 @@ -188,7 +188,7 @@ contains function psb_z_bjac_sizeof(prec) result(val) class(psb_z_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) then @@ -204,7 +204,7 @@ contains function psb_z_bjac_get_nzeros(prec) result(val) class(psb_z_bjac_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) then diff --git a/prec/psb_z_diagprec.f90 b/prec/psb_z_diagprec.f90 index e3874a8c1..5201989de 100644 --- a/prec/psb_z_diagprec.f90 +++ b/prec/psb_z_diagprec.f90 @@ -212,7 +212,7 @@ contains function psb_z_diag_sizeof(prec) result(val) class(psb_z_diag_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = (2*psb_sizeof_dp) * prec%get_nzeros() return @@ -220,7 +220,7 @@ contains function psb_z_diag_get_nzeros(prec) result(val) class(psb_z_diag_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 if (allocated(prec%dv)) val = val + prec%dv%get_nrows() diff --git a/prec/psb_z_nullprec.f90 b/prec/psb_z_nullprec.f90 index 6e651e732..7c0d26ffb 100644 --- a/prec/psb_z_nullprec.f90 +++ b/prec/psb_z_nullprec.f90 @@ -253,7 +253,7 @@ contains function psb_z_null_sizeof(prec) result(val) class(psb_z_null_prec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val val = 0 diff --git a/prec/psb_z_prec_type.f90 b/prec/psb_z_prec_type.f90 index 90fc8f9b8..15a53fe48 100644 --- a/prec/psb_z_prec_type.f90 +++ b/prec/psb_z_prec_type.f90 @@ -77,8 +77,8 @@ module psb_z_prec_type & psb_z_base_sparse_mat, psb_dpk_, psb_z_base_vect_type, & & psb_zprec_type, psb_i_base_vect_type implicit none - type(psb_zspmat_type), intent(in), target :: a - type(psb_desc_type), intent(inout), target :: desc_a + type(psb_zspmat_type), intent(in), target :: a + type(psb_desc_type), intent(inout), target :: desc_a class(psb_zprec_type), intent(inout), target :: prec integer(psb_ipk_), intent(out) :: info class(psb_z_base_sparse_mat), intent(in), optional :: amold @@ -201,10 +201,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if me=-1 call p%free(info) @@ -226,10 +228,12 @@ contains integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: me, err_act,i character(len=20) :: name - if(psb_get_errstatus() /= 0) return info=psb_success_ name = 'psb_precfree' call psb_erractionsave(err_act) + if (psb_errstatus_fatal()) then + info = psb_err_internal_error_ ; goto 9999 + end if me=-1 @@ -250,7 +254,7 @@ contains function psb_zprec_sizeof(prec) result(val) class(psb_zprec_type), intent(in) :: prec - integer(psb_long_int_k_) :: val + integer(psb_epk_) :: val integer(psb_ipk_) :: i val = 0 diff --git a/test/fileread/psb_cf_sample.f90 b/test/fileread/psb_cf_sample.f90 index cb9074ebb..93957db83 100644 --- a/test/fileread/psb_cf_sample.f90 +++ b/test/fileread/psb_cf_sample.f90 @@ -60,7 +60,7 @@ program psb_cf_sample ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode,& & methd, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize + integer(psb_epk_) :: amatsize, precsize, descsize real(psb_spk_) :: err, eps, cond character(len=5) :: afmt @@ -91,7 +91,7 @@ program psb_cf_sample name='psb_cf_sample' - if(psb_get_errstatus() /= 0) goto 9999 + if(psb_errstatus_fatal()) goto 9999 info=psb_success_ call psb_set_errverbosity(itwo) ! diff --git a/test/fileread/psb_df_sample.f90 b/test/fileread/psb_df_sample.f90 index 18e96b0b7..8dd33fea0 100644 --- a/test/fileread/psb_df_sample.f90 +++ b/test/fileread/psb_df_sample.f90 @@ -60,7 +60,7 @@ program psb_df_sample ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode,& & methd, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize + integer(psb_epk_) :: amatsize, precsize, descsize real(psb_dpk_) :: err, eps, cond character(len=5) :: afmt @@ -91,7 +91,7 @@ program psb_df_sample name='psb_df_sample' - if(psb_get_errstatus() /= 0) goto 9999 + if(psb_errstatus_fatal()) goto 9999 info=psb_success_ call psb_set_errverbosity(itwo) ! diff --git a/test/fileread/psb_sf_sample.f90 b/test/fileread/psb_sf_sample.f90 index 7d9439533..591e78c58 100644 --- a/test/fileread/psb_sf_sample.f90 +++ b/test/fileread/psb_sf_sample.f90 @@ -60,7 +60,7 @@ program psb_sf_sample ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode,& & methd, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize + integer(psb_epk_) :: amatsize, precsize, descsize real(psb_spk_) :: err, eps, cond character(len=5) :: afmt @@ -91,7 +91,7 @@ program psb_sf_sample name='psb_sf_sample' - if(psb_get_errstatus() /= 0) goto 9999 + if(psb_errstatus_fatal()) goto 9999 info=psb_success_ call psb_set_errverbosity(itwo) ! diff --git a/test/fileread/psb_zf_sample.f90 b/test/fileread/psb_zf_sample.f90 index b8ed73d28..40c5a0a2f 100644 --- a/test/fileread/psb_zf_sample.f90 +++ b/test/fileread/psb_zf_sample.f90 @@ -60,7 +60,7 @@ program psb_zf_sample ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode,& & methd, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize + integer(psb_epk_) :: amatsize, precsize, descsize real(psb_dpk_) :: err, eps, cond character(len=5) :: afmt @@ -91,7 +91,7 @@ program psb_zf_sample name='psb_zf_sample' - if(psb_get_errstatus() /= 0) goto 9999 + if(psb_errstatus_fatal()) goto 9999 info=psb_success_ call psb_set_errverbosity(itwo) ! diff --git a/test/hello/Makefile b/test/hello/Makefile index 6516a8688..fdc387e9b 100644 --- a/test/hello/Makefile +++ b/test/hello/Makefile @@ -1,6 +1,6 @@ -INSTALLDIR=../.. -INCDIR=$(INSTALLDIR)/include -MODDIR=$(INSTALLDIR)/modules/ +BASEDIR=../.. +INCDIR=$(BASEDIR)/include +MODDIR=$(BASEDIR)/modules/ include $(INCDIR)/Make.inc.psblas # # Libraries used diff --git a/test/idx/Makefile b/test/idx/Makefile new file mode 100644 index 000000000..f6179d092 --- /dev/null +++ b/test/idx/Makefile @@ -0,0 +1,43 @@ +INSTALLDIR=../.. +INCDIR=$(INSTALLDIR)/include +MODDIR=$(INSTALLDIR)/modules/ +include $(INCDIR)/Make.inc.psblas +# +# Libraries used +LIBDIR=$(INSTALLDIR)/lib +PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base +LDLIBS=$(PSBLDLIBS) +# +# Compilers and such +# +CCOPT= -g +FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG). + + +EXEDIR=./runs + +all: tryidxijk psb_d_pde3d test_gf731 + +tryidxijk: tryidxijk.o + $(FLINK) tryidxijk.o -o tryidxijk $(PSBLAS_LIB) $(LDLIBS) + /bin/mv tryidxijk $(EXEDIR) + +psb_d_pde3d: psb_d_pde3d.o + $(FLINK) psb_d_pde3d.o -o psb_d_pde3d $(PSBLAS_LIB) $(LDLIBS) + /bin/mv psb_d_pde3d $(EXEDIR) +test_gf731: test_gf731.o + $(FLINK) test_gf731.o -o test_gf731 $(PSBLAS_LIB) $(LDLIBS) + /bin/mv test_gf731 $(EXEDIR) + + + +clean: + /bin/rm -f tryidxijk.o test_gf731.o psb_d_pde3d.o *$(.mod) \ + $(EXEDIR)/tryidxijk $(EXEDIR)/psb_d_pde3d +verycleanlib: + (cd ../..; make veryclean) +lib: + (cd ../../; make library) + + + diff --git a/test/idx/psb_d_pde3d.f90 b/test/idx/psb_d_pde3d.f90 new file mode 100644 index 000000000..885bf00a5 --- /dev/null +++ b/test/idx/psb_d_pde3d.f90 @@ -0,0 +1,843 @@ +! +! Parallel Sparse BLAS version 3.5 +! (C) Copyright 2006-2018 +! Salvatore Filippone +! Alfredo Buttari +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions, and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! 3. The name of the PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +! POSSIBILITY OF SUCH DAMAGE. +! +! +! File: psb_d_pde3d.f90 +! +! Program: psb_d_pde3d +! This sample program solves a linear system obtained by discretizing a +! PDE with Dirichlet BCs. +! +! +! The PDE is a general second order equation in 3d +! +! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) +! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f +! dxdx dydy dzdz dx dy dz +! +! with Dirichlet boundary conditions +! u = g +! +! on the unit cube 0<=x,y,z<=1. +! +! +! Note that if b1=b2=b3=c=0., the PDE is the Laplace equation. +! +! There are three choices available for data distribution: +! 1. A simple BLOCK distribution +! 2. A ditribution based on arbitrary assignment of indices to processes, +! typically from a graph partitioner +! 3. A 3D distribution in which the unit cube is partitioned +! into subcubes, each one assigned to a process. +! +! +module psb_d_pde3d_mod + + + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_desc_type,& + & psb_dspmat_type, psb_d_vect_type, dzero,& + & psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type + + interface + function d_func_3d(x,y,z) result(val) + import :: psb_dpk_ + real(psb_dpk_), intent(in) :: x,y,z + real(psb_dpk_) :: val + end function d_func_3d + end interface + + interface psb_gen_pde3d + module procedure psb_d_gen_pde3d + end interface psb_gen_pde3d + +contains + + function d_null_func_3d(x,y,z) result(val) + + real(psb_dpk_), intent(in) :: x,y,z + real(psb_dpk_) :: val + + val = dzero + + end function d_null_func_3d + + + ! + ! subroutine to allocate and fill in the coefficient matrix and + ! the rhs. + ! + subroutine psb_d_gen_pde3d(ictxt,idim,a,bv,xv,desc_a,afmt,& + & a1,a2,a3,b1,b2,b3,c,g,info,f,amold,vmold,imold,partition,nrl,iv) + use psb_base_mod + use psb_util_mod + ! + ! Discretizes the partial differential equation + ! + ! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) + ! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f + ! dxdx dydy dzdz dx dy dz + ! + ! with Dirichlet boundary conditions + ! u = g + ! + ! on the unit cube 0<=x,y,z<=1. + ! + ! + ! Note that if b1=b2=b3=c=0., the PDE is the Laplace equation. + ! + implicit none + procedure(d_func_3d) :: b1,b2,b3,c,a1,a2,a3,g + integer(psb_ipk_) :: idim + type(psb_dspmat_type) :: a + type(psb_d_vect_type) :: xv,bv + type(psb_desc_type) :: desc_a + integer(psb_ipk_) :: ictxt, info + character(len=*) :: afmt + procedure(d_func_3d), optional :: f + class(psb_d_base_sparse_mat), optional :: amold + class(psb_d_base_vect_type), optional :: vmold + class(psb_i_base_vect_type), optional :: imold + integer(psb_ipk_), optional :: partition, nrl,iv(:) + + ! Local variables. + + integer(psb_ipk_), parameter :: nb=20 + type(psb_d_csc_sparse_mat) :: acsc + type(psb_d_coo_sparse_mat) :: acoo + type(psb_d_csr_sparse_mat) :: acsr + real(psb_dpk_) :: zt(nb),x,y,z + integer(psb_ipk_) :: m,n,nnz,nr,nt,glob_row,nlr,i,j,ii,ib,k, partition_ + integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner + ! For 3D partition + integer(psb_ipk_) :: npx,npy,npz, npdims(3),iamx,iamy,iamz,mynx,myny,mynz + integer(psb_ipk_), allocatable :: bndx(:),bndy(:),bndz(:) + ! Process grid + integer(psb_ipk_) :: np, iam + integer(psb_ipk_) :: icoeff + integer(psb_lpk_), allocatable :: myidx(:) + integer(psb_ipk_), allocatable :: irow(:),icol(:) + real(psb_dpk_), allocatable :: val(:) + ! deltah dimension of each grid cell + ! deltat discretization time + real(psb_dpk_) :: deltah, sqdeltah, deltah2 + real(psb_dpk_), parameter :: rhs=dzero,one=done,zero=dzero + real(psb_dpk_) :: t0, t1, t2, t3, tasb, talc, ttot, tgen, tcdasb + integer(psb_ipk_) :: err_act + procedure(d_func_3d), pointer :: f_ + character(len=20) :: name, ch_err,tmpfmt + + info = psb_success_ + name = 'create_matrix' + call psb_erractionsave(err_act) + + call psb_info(ictxt, iam, np) + + + if (present(f)) then + f_ => f + else + f_ => d_null_func_3d + end if + + deltah = done/(idim+2) + sqdeltah = deltah*deltah + deltah2 = (2*done)* deltah + + if (present(partition)) then + if ((1<= partition).and.(partition <= 3)) then + partition_ = partition + else + write(*,*) 'Invalid partition choice ',partition,' defaulting to 3' + partition_ = 3 + end if + else + partition_ = 3 + end if + + ! initialize array descriptor and sparse matrix storage. provide an + ! estimate of the number of non zeroes + t0 = psb_wtime() + m = idim*idim*idim + n = m + nnz = ((n*9)/(np)) + if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n + + select case(partition_) + case(1) + write(*,*) 'BLOCK partition ' + ! A BLOCK partition + if (present(nrl)) then + nr = nrl + else + ! + ! Using a simple BLOCK distribution. + ! + nt = (m+np-1)/np + nr = max(0,min(nt,m-(iam*nt))) + end if + + nt = nr + call psb_sum(ictxt,nt) + if (nt /= m) then + write(psb_err_unit,*) iam, 'Initialization error ',nr,nt,m + info = -1 + call psb_barrier(ictxt) + call psb_abort(ictxt) + return + end if + + ! + ! First example of use of CDALL: specify for each process a number of + ! contiguous rows + ! + call psb_cdall(ictxt,desc_a,info,nl=nr) + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + case(2) + write(*,*) 'User Defined Partition' + ! A partition defined by the user through IV + + if (present(iv)) then + if (size(iv) /= m) then + write(psb_err_unit,*) iam, 'Initialization error: wrong IV size',size(iv),m + info = -1 + call psb_barrier(ictxt) + call psb_abort(ictxt) + return + end if + else + write(psb_err_unit,*) iam, 'Initialization error: IV not present' + info = -1 + call psb_barrier(ictxt) + call psb_abort(ictxt) + return + end if + + ! + ! Second example of use of CDALL: specify for each row the + ! process that owns it + ! + call psb_cdall(ictxt,desc_a,info,vg=iv) + myidx = desc_a%get_global_indices() + nlr = size(myidx) + + case(3) + write(*,*) '3D coordinate planes Partition' + ! A 3-dimensional partition + + ! A nifty MPI function will split the process list + npdims = 0 + call mpi_dims_create(np,3,npdims,info) + npx = npdims(1) + npy = npdims(2) + npz = npdims(3) + + allocate(bndx(0:npx),bndy(0:npy),bndz(0:npz)) + ! We can reuse idx2ijk for process indices as well. + call idx2ijk(iamx,iamy,iamz,iam,npx,npy,npz,base=0) + ! Now let's split the 3D cube in hexahedra + call dist1Didx(bndx,idim,npx) + mynx = bndx(iamx+1)-bndx(iamx) + call dist1Didx(bndy,idim,npy) + myny = bndy(iamy+1)-bndy(iamy) + call dist1Didx(bndz,idim,npz) + mynz = bndz(iamz+1)-bndz(iamz) + + ! How many indices do I own? + nlr = mynx*myny*mynz + allocate(myidx(nlr)) + ! Now, let's generate the list of indices I own + nr = 0 + do i=bndx(iamx),bndx(iamx+1)-1 + do j=bndy(iamy),bndy(iamy+1)-1 + do k=bndz(iamz),bndz(iamz+1)-1 + nr = nr + 1 + call ijk2idx(myidx(nr),i,j,k,idim,idim,idim) + end do + end do + end do + if (nr /= nlr) then + write(psb_err_unit,*) iam,iamx,iamy,iamz, 'Initialization error: NR vs NLR ',& + & nr,nlr,mynx,myny,mynz + info = -1 + call psb_barrier(ictxt) + call psb_abort(ictxt) + end if + + ! + ! Third example of use of CDALL: specify for each process + ! the set of global indices it owns. + ! + call psb_cdall(ictxt,desc_a,info,vll=myidx) + + case default + write(psb_err_unit,*) iam, 'Initialization error: should not get here' + info = -1 + call psb_barrier(ictxt) + call psb_abort(ictxt) + return + end select + + if (info == psb_success_) call psb_spall(a,desc_a,info,nnz=nnz) + ! define rhs from boundary conditions; also build initial guess + if (info == psb_success_) call psb_geall(xv,desc_a,info) + if (info == psb_success_) call psb_geall(bv,desc_a,info) + + call psb_barrier(ictxt) + talc = psb_wtime()-t0 + + if (info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='allocation rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + ! we build an auxiliary matrix consisting of one row at a + ! time; just a small matrix. might be extended to generate + ! a bunch of rows per call. + ! + allocate(val(20*nb),irow(20*nb),& + &icol(20*nb),stat=info) + if (info /= psb_success_ ) then + info=psb_err_alloc_dealloc_ + call psb_errpush(info,name) + goto 9999 + endif + + + ! loop over rows belonging to current process in a block + ! distribution. + + call psb_barrier(ictxt) + t1 = psb_wtime() + do ii=1, nlr,nb + ib = min(nb,nlr-ii+1) + icoeff = 1 + do k=1,ib + i=ii+k-1 + ! local matrix pointer + glob_row=myidx(i) + ! compute gridpoint coordinates + call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) + ! x, y, z coordinates + x = (ix-1)*deltah + y = (iy-1)*deltah + z = (iz-1)*deltah + zt(k) = f_(x,y,z) +!!$ write(*,*) 'idx2ijk ',ix,iy,iz,glob_row,x,y,z,a1(x,y,z) +!!$ return + ! internal point: build discretization + ! + ! term depending on (x-1,y,z) + ! + val(icoeff) = -a1(x,y,z)/sqdeltah-b1(x,y,z)/deltah2 + if (ix == 1) then + zt(k) = g(dzero,y,z)*(-val(icoeff)) + zt(k) + else + icol(icoeff) = (ix-2)*idim*idim+(iy-1)*idim+(iz) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y-1,z) + val(icoeff) = -a2(x,y,z)/sqdeltah-b2(x,y,z)/deltah2 + if (iy == 1) then + zt(k) = g(x,dzero,z)*(-val(icoeff)) + zt(k) + else + icol(icoeff) = (ix-1)*idim*idim+(iy-2)*idim+(iz) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y,z-1) + val(icoeff)=-a3(x,y,z)/sqdeltah-b3(x,y,z)/deltah2 + if (iz == 1) then + zt(k) = g(x,y,dzero)*(-val(icoeff)) + zt(k) + else + icol(icoeff) = (ix-1)*idim*idim+(iy-1)*idim+(iz-1) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + ! term depending on (x,y,z) + val(icoeff)=(2*done)*(a1(x,y,z)+a2(x,y,z)+a3(x,y,z))/sqdeltah & + & + c(x,y,z) + icol(icoeff) = (ix-1)*idim*idim+(iy-1)*idim+(iz) + irow(icoeff) = glob_row + icoeff = icoeff+1 + ! term depending on (x,y,z+1) + val(icoeff)=-a3(x,y,z)/sqdeltah+b3(x,y,z)/deltah2 + if (iz == idim) then + zt(k) = g(x,y,done)*(-val(icoeff)) + zt(k) + else + icol(icoeff) = (ix-1)*idim*idim+(iy-1)*idim+(iz+1) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x,y+1,z) + val(icoeff)=-a2(x,y,z)/sqdeltah+b2(x,y,z)/deltah2 + if (iy == idim) then + zt(k) = g(x,done,z)*(-val(icoeff)) + zt(k) + else + icol(icoeff) = (ix-1)*idim*idim+(iy)*idim+(iz) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + ! term depending on (x+1,y,z) + val(icoeff)=-a1(x,y,z)/sqdeltah+b1(x,y,z)/deltah2 + if (ix==idim) then + zt(k) = g(done,y,z)*(-val(icoeff)) + zt(k) + else + icol(icoeff) = (ix)*idim*idim+(iy-1)*idim+(iz) + irow(icoeff) = glob_row + icoeff = icoeff+1 + endif + + end do + call psb_spins(icoeff-1,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) exit + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),bv,desc_a,info) + if(info /= psb_success_) exit + zt(:)=dzero + call psb_geins(ib,myidx(ii:ii+ib-1),zt(1:ib),xv,desc_a,info) + if(info /= psb_success_) exit + end do + + tgen = psb_wtime()-t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='insert rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + deallocate(val,irow,icol) + + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_cdasb(desc_a,info,mold=imold) + tcdasb = psb_wtime()-t1 + call psb_barrier(ictxt) + t1 = psb_wtime() + if (info == psb_success_) then + if (present(amold)) then + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=amold) + else + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt) + end if + end if + call psb_barrier(ictxt) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='asb rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + if (info == psb_success_) call psb_geasb(xv,desc_a,info,mold=vmold) + if (info == psb_success_) call psb_geasb(bv,desc_a,info,mold=vmold) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='asb rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tasb = psb_wtime()-t1 + call psb_barrier(ictxt) + ttot = psb_wtime() - t0 + + call psb_amx(ictxt,talc) + call psb_amx(ictxt,tgen) + call psb_amx(ictxt,tasb) + call psb_amx(ictxt,ttot) + if(iam == psb_root_) then + tmpfmt = a%get_fmt() + write(psb_out_unit,'("The matrix has been generated and assembled in ",a3," format.")')& + & tmpfmt + write(psb_out_unit,'("-allocation time : ",es12.5)') talc + write(psb_out_unit,'("-coeff. gen. time : ",es12.5)') tgen + write(psb_out_unit,'("-desc asbly time : ",es12.5)') tcdasb + write(psb_out_unit,'("- mat asbly time : ",es12.5)') tasb + write(psb_out_unit,'("-total time : ",es12.5)') ttot + + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + end subroutine psb_d_gen_pde3d + + +end module psb_d_pde3d_mod + +program psb_d_pde3d + use psb_base_mod + use psb_prec_mod + use psb_krylov_mod + use psb_util_mod + use psb_d_pde3d_mod + implicit none + + ! input parameters + character(len=20) :: kmethd, ptype + character(len=5) :: afmt + integer(psb_ipk_) :: idim + + ! miscellaneous + real(psb_dpk_), parameter :: one = done + real(psb_dpk_) :: t1, t2, tprec + + ! sparse matrix and preconditioner + type(psb_dspmat_type) :: a + type(psb_dprec_type) :: prec + ! descriptor + type(psb_desc_type) :: desc_a + ! dense vectors + type(psb_d_vect_type) :: xxv,bv + ! parallel environment + integer(psb_ipk_) :: ictxt, iam, np + + ! solver parameters + integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst + integer(psb_epk_) :: amatsize, precsize, descsize, d2size + real(psb_dpk_) :: err, eps + + ! other variables + integer(psb_ipk_) :: info, i + character(len=20) :: name,ch_err + character(len=40) :: fname + + info=psb_success_ + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='pde3d90' + call psb_set_errverbosity(itwo) + call psb_cd_set_large_threshold(itwo) + ! + ! Hello world + ! + if (iam == psb_root_) then + write(*,*) 'Welcome to PSBLAS version: ',psb_version_string_ + write(*,*) 'This is the ',trim(name),' sample program' + end if + ! + ! get parameters + ! + call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + + ! + ! allocate and fill in the coefficient matrix, rhs and initial guess + ! + !write(*,*) 'Check a1:',a1(dzero,dzero,dzero) + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_gen_pde3d(ictxt,idim,a,bv,xxv,desc_a,afmt,& + & a1,a2,a3,b1,b2,b3,c,g,info,partition=1) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_gen_pde3d' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iam == psb_root_) write(psb_out_unit,'("Overall matrix creation time : ",es12.5)')t2 + if (iam == psb_root_) write(psb_out_unit,'(" ")') + ! + ! prepare the preconditioner. + ! + if(iam == psb_root_) write(psb_out_unit,'("Setting preconditioner to : ",a)')ptype + call prec%init(ptype,info) + + call psb_barrier(ictxt) + t1 = psb_wtime() + call prec%build(a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_precbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + tprec = psb_wtime()-t1 + + call psb_amx(ictxt,tprec) + + if (iam == psb_root_) write(psb_out_unit,'("Preconditioner time : ",es12.5)')tprec + if (iam == psb_root_) write(psb_out_unit,'(" ")') + call prec%descr() + ! + ! iterative method parameters + ! + if(iam == psb_root_) write(psb_out_unit,'("Calling iterative method ",a)')kmethd + call psb_barrier(ictxt) + t1 = psb_wtime() + eps = 1.d-9 + call psb_krylov(kmethd,a,prec,bv,xxv,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='solver routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + call psb_amx(ictxt,t2) + amatsize = a%sizeof() + descsize = desc_a%sizeof() + precsize = prec%sizeof() + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + + if (iam == psb_root_) then + write(psb_out_unit,'(" ")') + write(psb_out_unit,'("Number of processes : ",i0)')np + write(psb_out_unit,'("Time to solve system : ",es12.5)')t2 + write(psb_out_unit,'("Time per iteration : ",es12.5)')t2/iter + write(psb_out_unit,'("Number of iterations : ",i0)')iter + write(psb_out_unit,'("Convergence indicator on exit : ",es12.5)')err + write(psb_out_unit,'("Info on exit : ",i0)')info + write(psb_out_unit,'("Total memory occupation for A: ",i12)')amatsize + write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize + write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize + write(psb_out_unit,'("Storage type for DESC_A: ",a)') desc_a%get_fmt() + end if + + + ! + ! cleanup storage and exit + ! + call psb_gefree(bv,desc_a,info) + call psb_gefree(xxv,desc_a,info) + call psb_spfree(a,desc_a,info) + call prec%free(info) + call psb_cdfree(desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_exit(ictxt) + stop + +9999 call psb_error(ictxt) + + stop + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + integer(psb_ipk_) :: ictxt + character(len=*) :: kmethd, ptype, afmt + integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst + integer(psb_ipk_) :: np, iam + integer(psb_ipk_) :: ip, inp_unit + character(len=1024) :: filename + + call psb_info(ictxt, iam, np) + + if (iam == 0) then + if (command_argument_count()>0) then + call get_command_argument(1,filename) + inp_unit = 30 + open(inp_unit,file=filename,action='read',iostat=info) + if (info /= 0) then + write(psb_err_unit,*) 'Could not open file ',filename,' for input' + call psb_abort(ictxt) + stop + else + write(psb_err_unit,*) 'Opened file ',trim(filename),' for input' + end if + else + inp_unit=psb_inp_unit + end if + read(inp_unit,*) ip + if (ip >= 3) then + read(inp_unit,*) kmethd + read(inp_unit,*) ptype + read(inp_unit,*) afmt + + read(inp_unit,*) idim + if (ip >= 4) then + read(inp_unit,*) istopc + else + istopc=1 + endif + if (ip >= 5) then + read(inp_unit,*) itmax + else + itmax=500 + endif + if (ip >= 6) then + read(inp_unit,*) itrace + else + itrace=-1 + endif + if (ip >= 7) then + read(inp_unit,*) irst + else + irst=1 + endif + ! broadcast parameters to all processors + + + write(psb_out_unit,'("Solving matrix : ell1")') + write(psb_out_unit,& + & '("Grid dimensions : ",i4," x ",i4," x ",i4)') & + & idim,idim,idim + write(psb_out_unit,'("Number of processors : ",i0)')np + write(psb_out_unit,'("Data distribution : BLOCK")') + write(psb_out_unit,'("Preconditioner : ",a)') ptype + write(psb_out_unit,'("Iterative method : ",a)') kmethd + write(psb_out_unit,'(" ")') + else + ! wrong number of parameter, print an error message and exit + call pr_usage(izero) + call psb_abort(ictxt) + stop 1 + endif + if (inp_unit /= psb_inp_unit) then + close(inp_unit) + end if + + end if + ! broadcast parameters to all processors + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,afmt) + call psb_bcast(ictxt,ptype) + call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,istopc) + call psb_bcast(ictxt,itmax) + call psb_bcast(ictxt,itrace) + call psb_bcast(ictxt,irst) + + return + + end subroutine get_parms + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer(psb_ipk_) :: iout + write(iout,*)'incorrect parameter(s) found' + write(iout,*)' usage: pde3d90 methd prec dim & + &[istop itmax itrace]' + write(iout,*)' where:' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' prec : bjac diag none' + write(iout,*)' dim number of points along each axis' + write(iout,*)' the size of the resulting linear ' + write(iout,*)' system is dim**3' + write(iout,*)' istop stopping criterion 1, 2 ' + write(iout,*)' itmax maximum number of iterations [500] ' + write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' >= 1 do tracing every itrace' + write(iout,*)' iterations ' + end subroutine pr_usage + ! + ! functions parametrizing the differential equation + ! + function b1(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: b1 + real(psb_dpk_), intent(in) :: x,y,z + b1=done/sqrt((3*done)) + end function b1 + function b2(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: b2 + real(psb_dpk_), intent(in) :: x,y,z + b2=done/sqrt((3*done)) + end function b2 + function b3(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: b3 + real(psb_dpk_), intent(in) :: x,y,z + b3=done/sqrt((3*done)) + end function b3 + function c(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: c + real(psb_dpk_), intent(in) :: x,y,z + c=dzero + end function c + function a1(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: a1 + real(psb_dpk_), intent(in) :: x,y,z + a1=done/80 + end function a1 + function a2(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: a2 + real(psb_dpk_), intent(in) :: x,y,z + a2=done/80 + end function a2 + function a3(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: a3 + real(psb_dpk_), intent(in) :: x,y,z + a3=done/80 + end function a3 + function g(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + real(psb_dpk_) :: g + real(psb_dpk_), intent(in) :: x,y,z + g = dzero + if (x == done) then + g = done + else if (x == dzero) then + g = exp(y**2-z**2) + end if + end function g + + +end program psb_d_pde3d + + diff --git a/test/idx/tryidxijk.f90 b/test/idx/tryidxijk.f90 new file mode 100644 index 000000000..31a71ad3f --- /dev/null +++ b/test/idx/tryidxijk.f90 @@ -0,0 +1,20 @@ +program tryidxijk + use psb_base_mod + use psb_util_mod + + integer(psb_lpk_) :: idx,idxm + integer(psb_ipk_) :: nx,ny,nz + integer(psb_ipk_) :: i,j,k, sidx + + idxm = 1000 + idxm = idxm*2000*1000 + nx = 2000 + ny = 2000 + nz = 2000 + do idx = idxm+300*1000*1000, idxm+300*1000*1000+50000 + call idx2ijk(i,j,k,idx,nx,ny,nz) + sidx = idx + write(*,*) 'idx2ijk: ',idx,i,j,k, sidx + end do + +end program tryidxijk diff --git a/test/kernel/d_file_spmv.f90 b/test/kernel/d_file_spmv.f90 index 49b6b834b..dc64a65cb 100644 --- a/test/kernel/d_file_spmv.f90 +++ b/test/kernel/d_file_spmv.f90 @@ -55,7 +55,7 @@ program d_file_spmv ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,& & methd, istopc, irst, nr - integer(psb_long_int_k_) :: amatsize, descsize, annz, nbytes + integer(psb_epk_) :: amatsize, descsize, annz, nbytes real(psb_dpk_) :: err, eps,cond character(len=5) :: afmt @@ -263,8 +263,8 @@ program d_file_spmv ! ! This computation is valid for CSR ! - nbytes = nr*(2*psb_sizeof_dp + psb_sizeof_int)+& - & annz*(psb_sizeof_dp + psb_sizeof_int) + nbytes = nr*(2*psb_sizeof_dp + psb_sizeof_ip)+& + & annz*(psb_sizeof_dp + psb_sizeof_ip) bdwdth = times*nbytes/(t2*1.d6) write(psb_out_unit,*) write(psb_out_unit,'("MBYTES/S : ",F20.3)') bdwdth diff --git a/test/kernel/pdgenspmv.f90 b/test/kernel/pdgenspmv.f90 index 32ae8428f..c587f7fab 100644 --- a/test/kernel/pdgenspmv.f90 +++ b/test/kernel/pdgenspmv.f90 @@ -412,7 +412,7 @@ program pdgenspmv ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, nr - integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size, annz, nbytes + integer(psb_epk_) :: amatsize, precsize, descsize, d2size, annz, nbytes real(psb_dpk_) :: err, eps integer(psb_ipk_), parameter :: times=10 @@ -523,8 +523,8 @@ program pdgenspmv ! ! This computation is valid for CSR ! - nbytes = nr*(2*psb_sizeof_dp + psb_sizeof_int)+& - & annz*(psb_sizeof_dp + psb_sizeof_int) + nbytes = nr*(2*psb_sizeof_dp + psb_sizeof_ip)+& + & annz*(psb_sizeof_dp + psb_sizeof_ip) bdwdth = times*nbytes/(t2*1.d6) write(psb_out_unit,*) write(psb_out_unit,'("MBYTES/S : ",F20.3)') bdwdth diff --git a/test/kernel/s_file_spmv.f90 b/test/kernel/s_file_spmv.f90 index f833b2593..fd3b415f3 100644 --- a/test/kernel/s_file_spmv.f90 +++ b/test/kernel/s_file_spmv.f90 @@ -55,7 +55,7 @@ program s_file_spmv ! solver paramters integer(psb_ipk_) :: iter, itmax, ierr, itrace, ircode, ipart,& & methd, istopc, irst, nr - integer(psb_long_int_k_) :: amatsize, descsize, annz, nbytes + integer(psb_epk_) :: amatsize, descsize, annz, nbytes real(psb_spk_) :: err, eps,cond character(len=5) :: afmt @@ -262,8 +262,8 @@ program s_file_spmv ! ! This computation is valid for CSR ! - nbytes = nr*(2*psb_sizeof_sp + psb_sizeof_int)+ & - & annz*(psb_sizeof_sp + psb_sizeof_int) + nbytes = nr*(2*psb_sizeof_sp + psb_sizeof_ip)+ & + & annz*(psb_sizeof_sp + psb_sizeof_ip) bdwdth = times*nbytes/(t2*1.d6) write(psb_out_unit,*) write(psb_out_unit,'("MBYTES/S : ",F20.3)') bdwdth diff --git a/test/pargen/psb_d_pde2d.f90 b/test/pargen/psb_d_pde2d.f90 index 8440281bb..d1ec686ea 100644 --- a/test/pargen/psb_d_pde2d.f90 +++ b/test/pargen/psb_d_pde2d.f90 @@ -191,15 +191,19 @@ contains type(psb_d_coo_sparse_mat) :: acoo type(psb_d_csr_sparse_mat) :: acsr real(psb_dpk_) :: zt(nb),x,y,z - integer(psb_ipk_) :: m,n,nnz,nr,nt,glob_row,nlr,i,j,ii,ib,k, partition_ + integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_ + integer(psb_lpk_) :: m,n,glob_row,nt integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner ! For 2D partition - integer(psb_ipk_) :: npx,npy,npdims(2),iamx,iamy,mynx,myny + ! Note: integer control variables going directly into an MPI call + ! must be 4 bytes, i.e. psb_mpk_ + integer(psb_mpk_) :: npdims(2), npp, minfo + integer(psb_ipk_) :: npx,npy,iamx,iamy,mynx,myny integer(psb_ipk_), allocatable :: bndx(:),bndy(:) ! Process grid integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: icoeff - integer(psb_ipk_), allocatable :: irow(:),icol(:),myidx(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) real(psb_dpk_), allocatable :: val(:) ! deltah dimension of each grid cell ! deltat discretization time @@ -241,7 +245,7 @@ contains ! initialize array descriptor and sparse matrix storage. provide an ! estimate of the number of non zeroes - m = idim*idim + m = (1_psb_lpk_)*idim*idim n = m nnz = ((n*7)/(np)) if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n @@ -554,8 +558,8 @@ program psb_d_pde2d integer(psb_ipk_) :: ictxt, iam, np ! solver parameters - integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size + integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart + integer(psb_epk_) :: amatsize, precsize, descsize, d2size real(psb_dpk_) :: err, eps ! other variables @@ -574,7 +578,7 @@ program psb_d_pde2d call psb_exit(ictxt) stop endif - if(psb_get_errstatus() /= 0) goto 9999 + if(psb_errstatus_fatal()) goto 9999 name='pde2d90' call psb_set_errverbosity(itwo) ! @@ -587,14 +591,14 @@ program psb_d_pde2d ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! call psb_barrier(ictxt) t1 = psb_wtime() - call psb_gen_pde2d(ictxt,idim,a,bv,xxv,desc_a,afmt,info) + call psb_gen_pde2d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) call psb_barrier(ictxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then @@ -697,10 +701,10 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) integer(psb_ipk_) :: ictxt character(len=*) :: kmethd, ptype, afmt - integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst + integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename @@ -730,21 +734,26 @@ contains read(inp_unit,*) idim if (ip >= 4) then + read(inp_unit,*) ipart + else + ipart = 3 + endif + if (ip >= 5) then read(inp_unit,*) istopc else istopc=1 endif - if (ip >= 5) then + if (ip >= 6) then read(inp_unit,*) itmax else itmax=500 endif - if (ip >= 6) then + if (ip >= 7) then read(inp_unit,*) itrace else itrace=-1 endif - if (ip >= 7) then + if (ip >= 8) then read(inp_unit,*) irst else irst=1 @@ -752,8 +761,16 @@ contains write(psb_out_unit,'("Solving matrix : ell1")') write(psb_out_unit,'("Grid dimensions : ",i5," x ",i5)')idim,idim - write(psb_out_unit,'("Number of processors : ",i0)')np - write(psb_out_unit,'("Data distribution : BLOCK")') + write(psb_out_unit,'("Number of processors : ",i0)') np + select case(ipart) + case(1) + write(psb_out_unit,'("Data distribution : BLOCK")') + case(3) + write(psb_out_unit,'("Data distribution : 2D")') + case default + ipart = 3 + write(psb_out_unit,'("Unknown data distrbution, defaulting to 2D")') + end select write(psb_out_unit,'("Preconditioner : ",a)') ptype write(psb_out_unit,'("Iterative method : ",a)') kmethd write(psb_out_unit,'(" ")') @@ -773,6 +790,7 @@ contains call psb_bcast(ictxt,afmt) call psb_bcast(ictxt,ptype) call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,ipart) call psb_bcast(ictxt,istopc) call psb_bcast(ictxt,itmax) call psb_bcast(ictxt,itrace) @@ -788,13 +806,14 @@ contains integer(psb_ipk_) :: iout write(iout,*)'incorrect parameter(s) found' write(iout,*)' usage: pde2d90 methd prec dim & - &[istop itmax itrace]' + &[ipart istop itmax itrace]' write(iout,*)' where:' write(iout,*)' methd: cgstab cgs rgmres bicgstabl' write(iout,*)' prec : bjac diag none' write(iout,*)' dim number of points along each axis' write(iout,*)' the size of the resulting linear ' - write(iout,*)' system is dim**3' + write(iout,*)' system is dim**2' + write(iout,*)' ipart data partition 1 3 ' write(iout,*)' istop stopping criterion 1, 2 ' write(iout,*)' itmax maximum number of iterations [500] ' write(iout,*)' itrace <=0 (no tracing, default) or ' diff --git a/test/pargen/psb_d_pde3d.f90 b/test/pargen/psb_d_pde3d.f90 index a34f462ef..e78b98254 100644 --- a/test/pargen/psb_d_pde3d.f90 +++ b/test/pargen/psb_d_pde3d.f90 @@ -61,9 +61,10 @@ module psb_d_pde3d_mod - use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_desc_type,& + use psb_base_mod, only : psb_dpk_, psb_ipk_, psb_lpk_, psb_desc_type,& & psb_dspmat_type, psb_d_vect_type, dzero,& - & psb_d_base_sparse_mat, psb_d_base_vect_type, psb_i_base_vect_type + & psb_d_base_sparse_mat, psb_d_base_vect_type, & + & psb_i_base_vect_type, psb_l_base_vect_type interface function d_func_3d(x,y,z) result(val) @@ -206,15 +207,19 @@ contains type(psb_d_coo_sparse_mat) :: acoo type(psb_d_csr_sparse_mat) :: acsr real(psb_dpk_) :: zt(nb),x,y,z - integer(psb_ipk_) :: m,n,nnz,nr,nt,glob_row,nlr,i,j,ii,ib,k, partition_ + integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_ + integer(psb_lpk_) :: m,n,glob_row,nt integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner ! For 3D partition - integer(psb_ipk_) :: npx,npy,npz, npdims(3),iamx,iamy,iamz,mynx,myny,mynz + ! Note: integer control variables going directly into an MPI call + ! must be 4 bytes, i.e. psb_mpk_ + integer(psb_mpk_) :: npdims(3), npp, minfo + integer(psb_ipk_) :: npx,npy,npz, iamx,iamy,iamz,mynx,myny,mynz integer(psb_ipk_), allocatable :: bndx(:),bndy(:),bndz(:) ! Process grid integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: icoeff - integer(psb_ipk_), allocatable :: irow(:),icol(:),myidx(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) real(psb_dpk_), allocatable :: val(:) ! deltah dimension of each grid cell ! deltat discretization time @@ -256,7 +261,7 @@ contains ! initialize array descriptor and sparse matrix storage. provide an ! estimate of the number of non zeroes - m = idim*idim*idim + m = (1_psb_lpk_*idim)*idim*idim n = m nnz = ((n*7)/(np)) if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n @@ -594,8 +599,8 @@ program psb_d_pde3d integer(psb_ipk_) :: ictxt, iam, np ! solver parameters - integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size + integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart + integer(psb_epk_) :: amatsize, precsize, descsize, d2size real(psb_dpk_) :: err, eps ! other variables @@ -614,10 +619,9 @@ program psb_d_pde3d call psb_exit(ictxt) stop endif - if(psb_get_errstatus() /= 0) goto 9999 + if(psb_errstatus_fatal()) goto 9999 name='pde3d90' call psb_set_errverbosity(itwo) - call psb_cd_set_large_threshold(itwo) ! ! Hello world ! @@ -628,14 +632,14 @@ program psb_d_pde3d ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! call psb_barrier(ictxt) t1 = psb_wtime() - call psb_gen_pde3d(ictxt,idim,a,bv,xxv,desc_a,afmt,info) + call psb_gen_pde3d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) call psb_barrier(ictxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then @@ -738,10 +742,10 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) integer(psb_ipk_) :: ictxt character(len=*) :: kmethd, ptype, afmt - integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst + integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename @@ -771,34 +775,45 @@ contains read(inp_unit,*) idim if (ip >= 4) then + read(inp_unit,*) ipart + else + ipart = 3 + endif + if (ip >= 5) then read(inp_unit,*) istopc else istopc=1 endif - if (ip >= 5) then + if (ip >= 6) then read(inp_unit,*) itmax else itmax=500 endif - if (ip >= 6) then + if (ip >= 7) then read(inp_unit,*) itrace else itrace=-1 endif - if (ip >= 7) then + if (ip >= 8) then read(inp_unit,*) irst else irst=1 endif - ! broadcast parameters to all processors - write(psb_out_unit,'("Solving matrix : ell1")') write(psb_out_unit,& & '("Grid dimensions : ",i4," x ",i4," x ",i4)') & & idim,idim,idim write(psb_out_unit,'("Number of processors : ",i0)')np - write(psb_out_unit,'("Data distribution : BLOCK")') + select case(ipart) + case(1) + write(psb_out_unit,'("Data distribution : BLOCK")') + case(3) + write(psb_out_unit,'("Data distribution : 3D")') + case default + ipart = 3 + write(psb_out_unit,'("Unknown data distrbution, defaulting to 3D")') + end select write(psb_out_unit,'("Preconditioner : ",a)') ptype write(psb_out_unit,'("Iterative method : ",a)') kmethd write(psb_out_unit,'(" ")') @@ -818,6 +833,7 @@ contains call psb_bcast(ictxt,afmt) call psb_bcast(ictxt,ptype) call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,ipart) call psb_bcast(ictxt,istopc) call psb_bcast(ictxt,itmax) call psb_bcast(ictxt,itrace) @@ -840,6 +856,7 @@ contains write(iout,*)' dim number of points along each axis' write(iout,*)' the size of the resulting linear ' write(iout,*)' system is dim**3' + write(iout,*)' ipart data partition 1 3 ' write(iout,*)' istop stopping criterion 1, 2 ' write(iout,*)' itmax maximum number of iterations [500] ' write(iout,*)' itrace <=0 (no tracing, default) or ' diff --git a/test/pargen/psb_s_pde2d.f90 b/test/pargen/psb_s_pde2d.f90 index ab33a8ba3..048a7a58b 100644 --- a/test/pargen/psb_s_pde2d.f90 +++ b/test/pargen/psb_s_pde2d.f90 @@ -191,15 +191,19 @@ contains type(psb_s_coo_sparse_mat) :: acoo type(psb_s_csr_sparse_mat) :: acsr real(psb_spk_) :: zt(nb),x,y,z - integer(psb_ipk_) :: m,n,nnz,nr,nt,glob_row,nlr,i,j,ii,ib,k, partition_ + integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_ + integer(psb_lpk_) :: m,n,glob_row,nt integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner ! For 2D partition - integer(psb_ipk_) :: npx,npy,npdims(2),iamx,iamy,mynx,myny + ! Note: integer control variables going directly into an MPI call + ! must be 4 bytes, i.e. psb_mpk_ + integer(psb_mpk_) :: npdims(2), npp, minfo + integer(psb_ipk_) :: npx,npy,iamx,iamy,mynx,myny integer(psb_ipk_), allocatable :: bndx(:),bndy(:) ! Process grid integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: icoeff - integer(psb_ipk_), allocatable :: irow(:),icol(:),myidx(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) real(psb_spk_), allocatable :: val(:) ! deltah dimension of each grid cell ! deltat discretization time @@ -241,7 +245,7 @@ contains ! initialize array descriptor and sparse matrix storage. provide an ! estimate of the number of non zeroes - m = idim*idim + m = (1_psb_lpk_)*idim*idim n = m nnz = ((n*7)/(np)) if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n @@ -554,8 +558,8 @@ program psb_s_pde2d integer(psb_ipk_) :: ictxt, iam, np ! solver parameters - integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size + integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart + integer(psb_epk_) :: amatsize, precsize, descsize, d2size real(psb_spk_) :: err, eps ! other variables @@ -574,7 +578,7 @@ program psb_s_pde2d call psb_exit(ictxt) stop endif - if(psb_get_errstatus() /= 0) goto 9999 + if(psb_errstatus_fatal()) goto 9999 name='pde2d90' call psb_set_errverbosity(itwo) ! @@ -587,14 +591,14 @@ program psb_s_pde2d ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! call psb_barrier(ictxt) t1 = psb_wtime() - call psb_gen_pde2d(ictxt,idim,a,bv,xxv,desc_a,afmt,info) + call psb_gen_pde2d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) call psb_barrier(ictxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then @@ -697,10 +701,10 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) integer(psb_ipk_) :: ictxt character(len=*) :: kmethd, ptype, afmt - integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst + integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename @@ -730,21 +734,26 @@ contains read(inp_unit,*) idim if (ip >= 4) then + read(inp_unit,*) ipart + else + ipart = 3 + endif + if (ip >= 5) then read(inp_unit,*) istopc else istopc=1 endif - if (ip >= 5) then + if (ip >= 6) then read(inp_unit,*) itmax else itmax=500 endif - if (ip >= 6) then + if (ip >= 7) then read(inp_unit,*) itrace else itrace=-1 endif - if (ip >= 7) then + if (ip >= 8) then read(inp_unit,*) irst else irst=1 @@ -752,8 +761,16 @@ contains write(psb_out_unit,'("Solving matrix : ell1")') write(psb_out_unit,'("Grid dimensions : ",i5," x ",i5)')idim,idim - write(psb_out_unit,'("Number of processors : ",i0)')np - write(psb_out_unit,'("Data distribution : BLOCK")') + write(psb_out_unit,'("Number of processors : ",i0)') np + select case(ipart) + case(1) + write(psb_out_unit,'("Data distribution : BLOCK")') + case(3) + write(psb_out_unit,'("Data distribution : 2D")') + case default + ipart = 3 + write(psb_out_unit,'("Unknown data distrbution, defaulting to 2D")') + end select write(psb_out_unit,'("Preconditioner : ",a)') ptype write(psb_out_unit,'("Iterative method : ",a)') kmethd write(psb_out_unit,'(" ")') @@ -773,6 +790,7 @@ contains call psb_bcast(ictxt,afmt) call psb_bcast(ictxt,ptype) call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,ipart) call psb_bcast(ictxt,istopc) call psb_bcast(ictxt,itmax) call psb_bcast(ictxt,itrace) @@ -788,13 +806,14 @@ contains integer(psb_ipk_) :: iout write(iout,*)'incorrect parameter(s) found' write(iout,*)' usage: pde2d90 methd prec dim & - &[istop itmax itrace]' + &[ipart istop itmax itrace]' write(iout,*)' where:' write(iout,*)' methd: cgstab cgs rgmres bicgstabl' write(iout,*)' prec : bjac diag none' write(iout,*)' dim number of points along each axis' write(iout,*)' the size of the resulting linear ' - write(iout,*)' system is dim**3' + write(iout,*)' system is dim**2' + write(iout,*)' ipart data partition 1 3 ' write(iout,*)' istop stopping criterion 1, 2 ' write(iout,*)' itmax maximum number of iterations [500] ' write(iout,*)' itrace <=0 (no tracing, default) or ' diff --git a/test/pargen/psb_s_pde3d.f90 b/test/pargen/psb_s_pde3d.f90 index 32c475939..6eb478726 100644 --- a/test/pargen/psb_s_pde3d.f90 +++ b/test/pargen/psb_s_pde3d.f90 @@ -61,9 +61,10 @@ module psb_s_pde3d_mod - use psb_base_mod, only : psb_spk_, psb_ipk_, psb_desc_type,& + use psb_base_mod, only : psb_spk_, psb_ipk_, psb_lpk_, psb_desc_type,& & psb_sspmat_type, psb_s_vect_type, szero,& - & psb_s_base_sparse_mat, psb_s_base_vect_type, psb_i_base_vect_type + & psb_s_base_sparse_mat, psb_s_base_vect_type, & + & psb_i_base_vect_type, psb_l_base_vect_type interface function s_func_3d(x,y,z) result(val) @@ -206,15 +207,19 @@ contains type(psb_s_coo_sparse_mat) :: acoo type(psb_s_csr_sparse_mat) :: acsr real(psb_spk_) :: zt(nb),x,y,z - integer(psb_ipk_) :: m,n,nnz,nr,nt,glob_row,nlr,i,j,ii,ib,k, partition_ + integer(psb_ipk_) :: nnz,nr,nlr,i,j,ii,ib,k, partition_ + integer(psb_lpk_) :: m,n,glob_row,nt integer(psb_ipk_) :: ix,iy,iz,ia,indx_owner ! For 3D partition - integer(psb_ipk_) :: npx,npy,npz, npdims(3),iamx,iamy,iamz,mynx,myny,mynz + ! Note: integer control variables going directly into an MPI call + ! must be 4 bytes, i.e. psb_mpk_ + integer(psb_mpk_) :: npdims(3), npp, minfo + integer(psb_ipk_) :: npx,npy,npz, iamx,iamy,iamz,mynx,myny,mynz integer(psb_ipk_), allocatable :: bndx(:),bndy(:),bndz(:) ! Process grid integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: icoeff - integer(psb_ipk_), allocatable :: irow(:),icol(:),myidx(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:),myidx(:) real(psb_spk_), allocatable :: val(:) ! deltah dimension of each grid cell ! deltat discretization time @@ -256,7 +261,7 @@ contains ! initialize array descriptor and sparse matrix storage. provide an ! estimate of the number of non zeroes - m = idim*idim*idim + m = (1_psb_lpk_*idim)*idim*idim n = m nnz = ((n*7)/(np)) if(iam == psb_root_) write(psb_out_unit,'("Generating Matrix (size=",i0,")...")')n @@ -594,8 +599,8 @@ program psb_s_pde3d integer(psb_ipk_) :: ictxt, iam, np ! solver parameters - integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize, d2size + integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, ipart + integer(psb_epk_) :: amatsize, precsize, descsize, d2size real(psb_spk_) :: err, eps ! other variables @@ -614,10 +619,9 @@ program psb_s_pde3d call psb_exit(ictxt) stop endif - if(psb_get_errstatus() /= 0) goto 9999 + if(psb_errstatus_fatal()) goto 9999 name='pde3d90' call psb_set_errverbosity(itwo) - call psb_cd_set_large_threshold(itwo) ! ! Hello world ! @@ -628,14 +632,14 @@ program psb_s_pde3d ! ! get parameters ! - call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + call get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) ! ! allocate and fill in the coefficient matrix, rhs and initial guess ! call psb_barrier(ictxt) t1 = psb_wtime() - call psb_gen_pde3d(ictxt,idim,a,bv,xxv,desc_a,afmt,info) + call psb_gen_pde3d(ictxt,idim,a,bv,xxv,desc_a,afmt,info,partition=ipart) call psb_barrier(ictxt) t2 = psb_wtime() - t1 if(info /= psb_success_) then @@ -738,10 +742,10 @@ contains ! ! get iteration parameters from standard input ! - subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst) + subroutine get_parms(ictxt,kmethd,ptype,afmt,idim,istopc,itmax,itrace,irst,ipart) integer(psb_ipk_) :: ictxt character(len=*) :: kmethd, ptype, afmt - integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst + integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst,ipart integer(psb_ipk_) :: np, iam integer(psb_ipk_) :: ip, inp_unit character(len=1024) :: filename @@ -771,34 +775,45 @@ contains read(inp_unit,*) idim if (ip >= 4) then + read(inp_unit,*) ipart + else + ipart = 3 + endif + if (ip >= 5) then read(inp_unit,*) istopc else istopc=1 endif - if (ip >= 5) then + if (ip >= 6) then read(inp_unit,*) itmax else itmax=500 endif - if (ip >= 6) then + if (ip >= 7) then read(inp_unit,*) itrace else itrace=-1 endif - if (ip >= 7) then + if (ip >= 8) then read(inp_unit,*) irst else irst=1 endif - ! broadcast parameters to all processors - write(psb_out_unit,'("Solving matrix : ell1")') write(psb_out_unit,& & '("Grid dimensions : ",i4," x ",i4," x ",i4)') & & idim,idim,idim write(psb_out_unit,'("Number of processors : ",i0)')np - write(psb_out_unit,'("Data distribution : BLOCK")') + select case(ipart) + case(1) + write(psb_out_unit,'("Data distribution : BLOCK")') + case(3) + write(psb_out_unit,'("Data distribution : 3D")') + case default + ipart = 3 + write(psb_out_unit,'("Unknown data distrbution, defaulting to 3D")') + end select write(psb_out_unit,'("Preconditioner : ",a)') ptype write(psb_out_unit,'("Iterative method : ",a)') kmethd write(psb_out_unit,'(" ")') @@ -818,6 +833,7 @@ contains call psb_bcast(ictxt,afmt) call psb_bcast(ictxt,ptype) call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,ipart) call psb_bcast(ictxt,istopc) call psb_bcast(ictxt,itmax) call psb_bcast(ictxt,itrace) @@ -840,6 +856,7 @@ contains write(iout,*)' dim number of points along each axis' write(iout,*)' the size of the resulting linear ' write(iout,*)' system is dim**3' + write(iout,*)' ipart data partition 1 3 ' write(iout,*)' istop stopping criterion 1, 2 ' write(iout,*)' itmax maximum number of iterations [500] ' write(iout,*)' itrace <=0 (no tracing, default) or ' diff --git a/test/pargen/runs/ppde.inp b/test/pargen/runs/ppde.inp index 4a1e7ab32..82f0bce6b 100644 --- a/test/pargen/runs/ppde.inp +++ b/test/pargen/runs/ppde.inp @@ -1,11 +1,12 @@ -7 Number of entries below this +8 Number of entries below this BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES FCG CGR BJAC Preconditioner NONE DIAG BJAC CSR Storage format for matrix A: CSR COO 040 Domain size (acutal system is this**3 (pde3d) or **2 (pde2d) ) +3 Partition: 1 BLOCK 3 3D 2 Stopping criterion 1 2 0100 MAXIT -01 ITRACE +-1 ITRACE 002 IRST restart for RGMRES and BiCGSTABL diff --git a/test/serial/d_matgen.F90 b/test/serial/d_matgen.F90 index 68d4f70d6..ab41f7906 100644 --- a/test/serial/d_matgen.F90 +++ b/test/serial/d_matgen.F90 @@ -381,7 +381,7 @@ program d_matgen ! solver parameters integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst - integer(psb_long_int_k_) :: amatsize, precsize, descsize + integer(psb_epk_) :: amatsize, precsize, descsize real(psb_dpk_) :: err, eps type(psb_d_csr_sparse_mat) :: acsr type(psb_d_xyz_sparse_mat) :: axyz diff --git a/test/serial/psb_d_xyz_mat_mod.f90 b/test/serial/psb_d_xyz_mat_mod.f90 index 245623d35..3ec9ef618 100644 --- a/test/serial/psb_d_xyz_mat_mod.f90 +++ b/test/serial/psb_d_xyz_mat_mod.f90 @@ -137,7 +137,7 @@ module psb_d_xyz_mat_mod !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_d_xyz_mold(a,b,info) - import :: psb_ipk_, psb_d_xyz_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ + import :: psb_ipk_, psb_d_xyz_sparse_mat, psb_d_base_sparse_mat, psb_epk_ class(psb_d_xyz_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info @@ -531,11 +531,11 @@ contains function d_xyz_sizeof(a) result(res) implicit none class(psb_d_xyz_sparse_mat), intent(in) :: a - integer(psb_long_int_k_) :: res + integer(psb_epk_) :: res res = 8 res = res + psb_sizeof_dp * size(a%val) - res = res + psb_sizeof_int * size(a%irp) - res = res + psb_sizeof_int * size(a%ja) + res = res + psb_sizeof_ip * size(a%irp) + res = res + psb_sizeof_ip * size(a%ja) end function d_xyz_sizeof diff --git a/util/psb_blockpart_mod.f90 b/util/psb_blockpart_mod.f90 index 39873b897..08eacb43e 100644 --- a/util/psb_blockpart_mod.f90 +++ b/util/psb_blockpart_mod.f90 @@ -36,14 +36,14 @@ module psb_blockpart_mod contains subroutine part_block(global_indx,n,np,pv,nv) - use psb_base_mod, only : psb_ipk_, psb_mpik_ + use psb_base_mod, only : psb_ipk_, psb_mpk_, psb_lpk_ implicit none - integer(psb_ipk_), intent(in) :: global_indx, n + integer(psb_lpk_), intent(in) :: global_indx, n integer(psb_ipk_), intent(in) :: np integer(psb_ipk_), intent(out) :: nv integer(psb_ipk_), intent(out) :: pv(*) - integer(psb_ipk_) :: dim_block + integer(psb_lpk_) :: dim_block dim_block = (n + np - 1)/np nv = 1 @@ -56,10 +56,11 @@ contains subroutine bld_partblock(n,np,ivg) - use psb_base_mod, only : psb_ipk_ - integer(psb_ipk_) :: n,np,ivg(*) + use psb_base_mod, only : psb_ipk_, psb_mpk_, psb_lpk_ + integer(psb_lpk_) :: n + integer(psb_ipk_) :: np,ivg(*) - integer(psb_ipk_) :: dim_block,i + integer(psb_lpk_) :: dim_block,i dim_block = (n + np - 1)/np @@ -69,7 +70,5 @@ contains end subroutine bld_partblock - - end module psb_blockpart_mod diff --git a/util/psb_c_hbio_impl.f90 b/util/psb_c_hbio_impl.f90 index 1bed81efe..06c327c56 100644 --- a/util/psb_c_hbio_impl.f90 +++ b/util/psb_c_hbio_impl.f90 @@ -361,3 +361,338 @@ subroutine chb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) write(psb_err_unit,*) 'Error while opening ',filename return end subroutine chb_write + + +subroutine lchb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_base_mod + implicit none + type(psb_lcspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: iret + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + complex(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + + character :: rhstype*3,type*3,key*8 + character(len=72) :: mtitle_ + character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 + integer(psb_lpk_) :: indcrd, ptrcrd, totcrd,& + & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix + type(psb_lc_csc_sparse_mat) :: acsc + type(psb_lc_coo_sparse_mat) :: acoo + integer(psb_ipk_) :: ircode, infile, info + integer(psb_lpk_) :: i,nzr + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + iret = 0 + ircode = 0 + if (present(filename)) then + if (filename == '-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call acsc%allocate(nrow,ncol,nnzero) + if (ircode /= 0 ) then + write(psb_err_unit,*) 'Memory allocation failed' + goto 993 + end if + + if (present(mtitle)) mtitle=mtitle_ + + + if (psb_tolower(type(1:1)) == 'c') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + call a%mv_from(acsc) + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 + + else if (psb_tolower(type(2:2)) == 'h') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = conjg(acoo%val(i)) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 + + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + + call a%cscnv(ircode,type='csr') + if (infile /= 5) close(infile) + + return + + ! open failed +901 iret=901 + write(psb_err_unit,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(psb_err_unit,*) 'HB_READ: Unexpected end of file ' + return +993 iret=993 + write(psb_err_unit,*) 'HB_READ: Memory allocation failure' + return +end subroutine lchb_read + +subroutine lchb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_base_mod + implicit none + type(psb_lcspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + complex(psb_spk_), optional :: rhs(:), g(:), x(:) + integer(psb_ipk_) :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer(psb_ipk_), parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer(psb_ipk_), parameter :: jval=2,jrhs=2 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + type(psb_lc_csc_sparse_mat) :: acsc + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype*3,type*3 + + integer(psb_lpk_) :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename == '-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + + call acsc%cp_from_fmt(a%a, iret) + if (iret /= 0) return + + + nrow = acsc%get_nrows() + ncol = acsc%get_ncols() + nnzero = acsc%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'CUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acsc%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(psb_err_unit,*) 'Error while opening ',filename + return +end subroutine lchb_write diff --git a/util/psb_c_mat_dist_impl.f90 b/util/psb_c_mat_dist_impl.f90 index 0df855f6f..dfaeac251 100644 --- a/util/psb_c_mat_dist_impl.f90 +++ b/util/psb_c_mat_dist_impl.f90 @@ -88,11 +88,11 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& ! local variables logical :: use_parts, use_v integer(psb_ipk_) :: np, iam, np_sharing - integer(psb_ipk_) :: i_count, j_count,& - & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& - & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer(psb_ipk_) :: k_count, root, liwork, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act + integer(psb_lpk_) :: i_count, j_count, nrow, ncol, ig integer(psb_ipk_), allocatable :: iwork(:), iwrk2(:) - integer(psb_ipk_), allocatable :: irow(:),icol(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:) complex(psb_spk_), allocatable :: val(:) integer(psb_ipk_), parameter :: nb=30 real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 @@ -140,8 +140,7 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=liwork - call psb_errpush(info,name,i_err=int_err,a_err='integer') + call psb_errpush(info,name,i_err=(/liwork/),a_err='integer') goto 9999 endif if (iam == root) then @@ -339,3 +338,319 @@ subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& return end subroutine psb_cmatdist + + + +subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& + & info, parts, v, inroot,fmt,mold) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(psb_cspmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! + ! type(psb_cspmat_type) :: a + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer(psb_ipk_), intent(in) :: global_indx, n, np + ! integer(psb_ipk_), intent(out) :: nv + ! integer(psb_ipk_), intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer(psb_ipk_) :: ictxt + ! on entry: the PSBLAS parallel environment context. + ! + ! type (desc_type) :: desc_a + ! on exit : the updated array descriptor + ! + ! integer(psb_ipk_), optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + use psb_mat_mod + implicit none + + ! parameters + type(psb_lcspmat_type) :: a_glob + integer(psb_ipk_) :: ictxt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: inroot + character(len=*), optional :: fmt + class(psb_c_base_sparse_mat), optional :: mold + procedure(psb_parts), optional :: parts + integer(psb_ipk_), optional :: v(:) + + ! local variables + logical :: use_parts, use_v + integer(psb_ipk_) :: np, iam, np_sharing, root, iproc + integer(psb_ipk_) :: err_act, il, inz + integer(psb_lpk_) :: k_count, liwork, nnzero, nrhs,& + & i, ll, nz, isize, nnr, err + integer(psb_lpk_) :: i_count, j_count, nrow, ncol, ig + integer(psb_ipk_), allocatable :: iwork(:), iwrk2(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:) + complex(psb_spk_), allocatable :: val(:) + integer(psb_ipk_), parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = psb_success_ + err = 0 + name = 'psb_c_mat_dist' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + nrow = a_glob%get_nrows() + ncol = a_glob%get_ncols() + if (nrow /= ncol) then + write(psb_err_unit,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = a_glob%get_nzeros() + nrhs = 1 + endif + + use_parts = present(parts) + use_v = present(v) + if (count((/ use_parts, use_v /)) /= 1) then + info=psb_err_no_optional_arg_ + call psb_errpush(info,name,a_err=" v, parts") + goto 9999 + endif + + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), iwrk2(np),stat = info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,l_err=(/liwork/),a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (use_parts) then + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + else if (use_v) then + call psb_cdall(ictxt,desc_a,info,vg=v) + else + info = -1 + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + inz = ((nnzero+np-1)/np) + call psb_spall(a,desc_a,info,nnz=inz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + if (use_parts) then + call parts(i_count,nrow,np,iwork, np_sharing) + ! + ! np_sharing allows for overlap in the data distribution. + ! If an index is overlapped, then we have to send its row + ! to multiple processes. NOTE: we are assuming the output + ! from PARTS is coherent, otherwise a deadlock is the most + ! likely outcome. + ! + j_count = i_count + if (np_sharing == 1) then + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwrk2, np_sharing) + if (np_sharing /= 1 ) exit + if (iwrk2(1) /= iproc ) exit + end do + end if + else + np_sharing = 1 + j_count = i_count + iproc = v(i_count) + iwork(1:np_sharing) = iproc + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + end if + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= psb_success_) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(psb_err_unit,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + do k_count = 1, np_sharing + iproc = iwork(k_count) + + if (iproc == iam) then + il = ll + call psb_spins(il,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + end do + else if (iam /= root) then + + do k_count = 1, np_sharing + iproc = iwork(k_count) + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(psb_err_unit,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_snd(ictxt,ll,root) + il = ll + call psb_spins(il,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + end do + endif + i_count = j_count + end do + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) + t3 = psb_wtime() + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(psb_out_unit,*) 'descriptor assembly: ',t1-t0 + write(psb_out_unit,*) 'sparse matrix assembly: ',t3-t2 + end if + + + + deallocate(val,irow,icol,iwork,iwrk2,stat=info) + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lcmatdist diff --git a/util/psb_c_mat_dist_mod.f90 b/util/psb_c_mat_dist_mod.f90 index 7ce6abd93..422f4e963 100644 --- a/util/psb_c_mat_dist_mod.f90 +++ b/util/psb_c_mat_dist_mod.f90 @@ -31,7 +31,8 @@ ! module psb_c_mat_dist_mod use psb_base_mod, only : psb_ipk_, psb_spk_, psb_desc_type, psb_parts, & - & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_vect_type + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_vect_type, & + & psb_lcspmat_type interface psb_matdist subroutine psb_cmatdist(a_glob, a, ictxt, desc_a,& @@ -91,6 +92,64 @@ module psb_c_mat_dist_mod procedure(psb_parts), optional :: parts integer(psb_ipk_), optional :: v(:) end subroutine psb_cmatdist + subroutine psb_lcmatdist(a_glob, a, ictxt, desc_a,& + & info, parts, v, inroot,fmt,mold) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(psb_lcspmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! + ! type(psb_cspmat_type) :: a + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer(psb_ipk_), intent(in) :: global_indx, n, np + ! integer(psb_ipk_), intent(out) :: nv + ! integer(psb_ipk_), intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer(psb_ipk_) :: ictxt + ! on entry: the PSBLAS parallel environment context. + ! + ! type (desc_type) :: desc_a + ! on exit : the updated array descriptor + ! + ! + ! integer(psb_ipk_), optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + import :: psb_ipk_, psb_cspmat_type, psb_spk_, psb_desc_type,& + & psb_c_base_sparse_mat, psb_c_vect_type, psb_parts, & + & psb_lcspmat_type + implicit none + + ! parameters + type(psb_lcspmat_type) :: a_glob + integer(psb_ipk_) :: ictxt + type(psb_cspmat_type) :: a + type(psb_desc_type) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: inroot + character(len=*), optional :: fmt + class(psb_c_base_sparse_mat), optional :: mold + procedure(psb_parts), optional :: parts + integer(psb_ipk_), optional :: v(:) + end subroutine psb_lcmatdist end interface end module psb_c_mat_dist_mod diff --git a/util/psb_c_mmio_impl.f90 b/util/psb_c_mmio_impl.f90 index e2f0ac60f..a07c8e752 100644 --- a/util/psb_c_mmio_impl.f90 +++ b/util/psb_c_mmio_impl.f90 @@ -461,3 +461,179 @@ subroutine cmm_mat_write(a,mtitle,info,iunit,filename) write(psb_err_unit,*) 'Error while opening ',filename return end subroutine cmm_mat_write + +subroutine lcmm_mat_read(a, info, iunit, filename) + use psb_base_mod + implicit none + type(psb_lcspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer(psb_lpk_) :: nrow, ncol, nnzero, i,nzr + integer(psb_ipk_) :: ircode,infile + type(psb_lc_coo_sparse_mat), allocatable :: acoo + real(psb_spk_) :: are, aim + info = psb_success_ + + if (present(filename)) then + if (filename == '-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt) /= 'coordinate')) then + write(psb_err_unit,*) 'READ_MATRIX: input file type not yet supported' + info=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + allocate(acoo, stat=ircode) + if (ircode /= 0) goto 993 + if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_spk_) + end do + call acoo%set_nzeros(nnzero) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_spk_) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'hermitian')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_spk_) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = conjg(acoo%val(i)) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + info=904 + end if + if (infile /= 5) close(infile) + return + + ! open failed +901 info=901 + write(psb_err_unit,*) 'read_matrix: could not open file ',filename,' for input' + return +902 info=902 + write(psb_err_unit,*) 'READ_MATRIX: Unexpected end of file ' + return +905 info=905 + write(psb_err_unit,*) 'READ_MATRIX: Error at line',i + return +993 info=993 + write(psb_err_unit,*) 'READ_MATRIX: Memory allocation failure' + return +end subroutine lcmm_mat_read + + +subroutine lcmm_mat_write(a,mtitle,info,iunit,filename) + use psb_base_mod + implicit none + type(psb_lcspmat_type), intent(in) :: a + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer(psb_ipk_) :: iout + + + info = psb_success_ + + if (present(filename)) then + if (filename == '-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call a%print(iout,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + info=901 + write(psb_err_unit,*) 'Error while opening ',filename + return +end subroutine lcmm_mat_write diff --git a/util/psb_c_renum_impl.F90 b/util/psb_c_renum_impl.F90 index c2caca329..4a1cf220e 100644 --- a/util/psb_c_renum_impl.F90 +++ b/util/psb_c_renum_impl.F90 @@ -267,7 +267,7 @@ contains name = 'mat_renum_amd' call psb_erractionsave(err_act) -#if defined(HAVE_AMD) +#if defined(HAVE_AMD) && defined(IPK4) info = psb_success_ nr = a%get_nrows() diff --git a/util/psb_d_hbio_impl.f90 b/util/psb_d_hbio_impl.f90 index dff5423a5..cca909952 100644 --- a/util/psb_d_hbio_impl.f90 +++ b/util/psb_d_hbio_impl.f90 @@ -314,3 +314,290 @@ subroutine dhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) write(psb_err_unit,*) 'Error while opening ',filename return end subroutine dhb_write + +subroutine ldhb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_base_mod + implicit none + type(psb_ldspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: iret + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + real(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + + character :: rhstype*3,type*3,key*8 + character(len=72) :: mtitle_ + character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 + integer(psb_lpk_) :: indcrd, ptrcrd, totcrd,& + & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix + type(psb_ld_csc_sparse_mat) :: acsc + type(psb_ld_coo_sparse_mat) :: acoo + integer(psb_ipk_) :: ircode, infile, info + integer(psb_lpk_) :: i,nzr + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + iret = 0 + ircode = 0 + if (present(filename)) then + if (filename == '-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call acsc%allocate(nrow,ncol,nnzero) + if (ircode /= 0 ) then + write(psb_err_unit,*) 'Memory allocation failed' + goto 993 + end if + + if (present(mtitle)) mtitle=mtitle_ + + + if (psb_tolower(type(1:1)) == 'r') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + call a%mv_from(acsc) + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 + + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + + call a%cscnv(ircode,type='csr') + if (infile /= 5) close(infile) + + return + + ! open failed +901 iret=901 + write(psb_err_unit,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(psb_err_unit,*) 'HB_READ: Unexpected end of file ' + return +993 iret=993 + write(psb_err_unit,*) 'HB_READ: Memory allocation failure' + return +end subroutine ldhb_read + +subroutine ldhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_base_mod + implicit none + type(psb_ldspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_dpk_), optional :: rhs(:), g(:), x(:) + integer(psb_ipk_) :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer(psb_ipk_), parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer(psb_ipk_), parameter :: jval=4,jrhs=4 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + type(psb_ld_csc_sparse_mat) :: acsc + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype*3,type*3 + + integer(psb_lpk_) :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename == '-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + + call acsc%cp_from_fmt(a%a, iret) + if (iret /= 0) return + + + nrow = acsc%get_nrows() + ncol = acsc%get_ncols() + nnzero = acsc%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'RUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acsc%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(psb_err_unit,*) 'Error while opening ',filename + return +end subroutine ldhb_write diff --git a/util/psb_d_mat_dist_impl.f90 b/util/psb_d_mat_dist_impl.f90 index 97ed77beb..90236db29 100644 --- a/util/psb_d_mat_dist_impl.f90 +++ b/util/psb_d_mat_dist_impl.f90 @@ -88,11 +88,11 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& ! local variables logical :: use_parts, use_v integer(psb_ipk_) :: np, iam, np_sharing - integer(psb_ipk_) :: i_count, j_count,& - & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& - & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer(psb_ipk_) :: k_count, root, liwork, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act + integer(psb_lpk_) :: i_count, j_count, nrow, ncol, ig integer(psb_ipk_), allocatable :: iwork(:), iwrk2(:) - integer(psb_ipk_), allocatable :: irow(:),icol(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:) real(psb_dpk_), allocatable :: val(:) integer(psb_ipk_), parameter :: nb=30 real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 @@ -140,8 +140,7 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=liwork - call psb_errpush(info,name,i_err=int_err,a_err='integer') + call psb_errpush(info,name,i_err=(/liwork/),a_err='integer') goto 9999 endif if (iam == root) then @@ -339,3 +338,319 @@ subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& return end subroutine psb_dmatdist + + + +subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& + & info, parts, v, inroot,fmt,mold) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(psb_dspmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! + ! type(psb_dspmat_type) :: a + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer(psb_ipk_), intent(in) :: global_indx, n, np + ! integer(psb_ipk_), intent(out) :: nv + ! integer(psb_ipk_), intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer(psb_ipk_) :: ictxt + ! on entry: the PSBLAS parallel environment context. + ! + ! type (desc_type) :: desc_a + ! on exit : the updated array descriptor + ! + ! integer(psb_ipk_), optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + use psb_mat_mod + implicit none + + ! parameters + type(psb_ldspmat_type) :: a_glob + integer(psb_ipk_) :: ictxt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: inroot + character(len=*), optional :: fmt + class(psb_d_base_sparse_mat), optional :: mold + procedure(psb_parts), optional :: parts + integer(psb_ipk_), optional :: v(:) + + ! local variables + logical :: use_parts, use_v + integer(psb_ipk_) :: np, iam, np_sharing, root, iproc + integer(psb_ipk_) :: err_act, il, inz + integer(psb_lpk_) :: k_count, liwork, nnzero, nrhs,& + & i, ll, nz, isize, nnr, err + integer(psb_lpk_) :: i_count, j_count, nrow, ncol, ig + integer(psb_ipk_), allocatable :: iwork(:), iwrk2(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:) + real(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_), parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = psb_success_ + err = 0 + name = 'psb_d_mat_dist' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + nrow = a_glob%get_nrows() + ncol = a_glob%get_ncols() + if (nrow /= ncol) then + write(psb_err_unit,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = a_glob%get_nzeros() + nrhs = 1 + endif + + use_parts = present(parts) + use_v = present(v) + if (count((/ use_parts, use_v /)) /= 1) then + info=psb_err_no_optional_arg_ + call psb_errpush(info,name,a_err=" v, parts") + goto 9999 + endif + + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), iwrk2(np),stat = info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,l_err=(/liwork/),a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (use_parts) then + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + else if (use_v) then + call psb_cdall(ictxt,desc_a,info,vg=v) + else + info = -1 + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + inz = ((nnzero+np-1)/np) + call psb_spall(a,desc_a,info,nnz=inz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + if (use_parts) then + call parts(i_count,nrow,np,iwork, np_sharing) + ! + ! np_sharing allows for overlap in the data distribution. + ! If an index is overlapped, then we have to send its row + ! to multiple processes. NOTE: we are assuming the output + ! from PARTS is coherent, otherwise a deadlock is the most + ! likely outcome. + ! + j_count = i_count + if (np_sharing == 1) then + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwrk2, np_sharing) + if (np_sharing /= 1 ) exit + if (iwrk2(1) /= iproc ) exit + end do + end if + else + np_sharing = 1 + j_count = i_count + iproc = v(i_count) + iwork(1:np_sharing) = iproc + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + end if + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= psb_success_) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(psb_err_unit,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + do k_count = 1, np_sharing + iproc = iwork(k_count) + + if (iproc == iam) then + il = ll + call psb_spins(il,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + end do + else if (iam /= root) then + + do k_count = 1, np_sharing + iproc = iwork(k_count) + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(psb_err_unit,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_snd(ictxt,ll,root) + il = ll + call psb_spins(il,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + end do + endif + i_count = j_count + end do + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) + t3 = psb_wtime() + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(psb_out_unit,*) 'descriptor assembly: ',t1-t0 + write(psb_out_unit,*) 'sparse matrix assembly: ',t3-t2 + end if + + + + deallocate(val,irow,icol,iwork,iwrk2,stat=info) + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_ldmatdist diff --git a/util/psb_d_mat_dist_mod.f90 b/util/psb_d_mat_dist_mod.f90 index 6632600c2..beb7f113d 100644 --- a/util/psb_d_mat_dist_mod.f90 +++ b/util/psb_d_mat_dist_mod.f90 @@ -31,7 +31,8 @@ ! module psb_d_mat_dist_mod use psb_base_mod, only : psb_ipk_, psb_dpk_, psb_desc_type, psb_parts, & - & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_vect_type + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_vect_type, & + & psb_ldspmat_type interface psb_matdist subroutine psb_dmatdist(a_glob, a, ictxt, desc_a,& @@ -91,6 +92,64 @@ module psb_d_mat_dist_mod procedure(psb_parts), optional :: parts integer(psb_ipk_), optional :: v(:) end subroutine psb_dmatdist + subroutine psb_ldmatdist(a_glob, a, ictxt, desc_a,& + & info, parts, v, inroot,fmt,mold) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(psb_ldspmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! + ! type(psb_dspmat_type) :: a + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer(psb_ipk_), intent(in) :: global_indx, n, np + ! integer(psb_ipk_), intent(out) :: nv + ! integer(psb_ipk_), intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer(psb_ipk_) :: ictxt + ! on entry: the PSBLAS parallel environment context. + ! + ! type (desc_type) :: desc_a + ! on exit : the updated array descriptor + ! + ! + ! integer(psb_ipk_), optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + import :: psb_ipk_, psb_dspmat_type, psb_dpk_, psb_desc_type,& + & psb_d_base_sparse_mat, psb_d_vect_type, psb_parts, & + & psb_ldspmat_type + implicit none + + ! parameters + type(psb_ldspmat_type) :: a_glob + integer(psb_ipk_) :: ictxt + type(psb_dspmat_type) :: a + type(psb_desc_type) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: inroot + character(len=*), optional :: fmt + class(psb_d_base_sparse_mat), optional :: mold + procedure(psb_parts), optional :: parts + integer(psb_ipk_), optional :: v(:) + end subroutine psb_ldmatdist end interface end module psb_d_mat_dist_mod diff --git a/util/psb_d_mmio_impl.f90 b/util/psb_d_mmio_impl.f90 index 7026f68d0..506ed1e9f 100644 --- a/util/psb_d_mmio_impl.f90 +++ b/util/psb_d_mmio_impl.f90 @@ -452,3 +452,180 @@ subroutine dmm_mat_write(a,mtitle,info,iunit,filename) write(psb_err_unit,*) 'Error while opening ',filename return end subroutine dmm_mat_write + + +subroutine ldmm_mat_read(a, info, iunit, filename) + use psb_base_mod + implicit none + type(psb_ldspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer(psb_lpk_) :: nrow, ncol, nnzero, i, nzr + integer(psb_ipk_) :: ircode, infile + type(psb_ld_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + + if (present(filename)) then + if (filename == '-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt) /= 'coordinate')) then + write(psb_err_unit,*) 'READ_MATRIX: input file type not yet supported' + info=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + allocate(acoo, stat=ircode) + if (ircode /= 0) goto 993 + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),acoo%val(i) + end do + call acoo%set_nzeros(nnzero) + + else if ((psb_tolower(type) == 'pattern').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i) + end do + acoo%val(:) = done + call acoo%set_nzeros(nnzero) + + else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),acoo%val(i) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + + else if ((psb_tolower(type) == 'pattern').and.(psb_tolower(sym) == 'symmetric')) then + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i) + end do + acoo%val(:) = done + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + info=904 + end if + + if (info == 0) then + call acoo%fix(info) + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + end if + + if (infile /= 5) close(infile) + return + + ! open failed +901 info=901 + write(psb_err_unit,*) 'read_matrix: could not open file ',filename,' for input' + return +902 info=902 + write(psb_err_unit,*) 'READ_MATRIX: Unexpected end of file ' + return +905 info=905 + write(psb_err_unit,*) 'READ_MATRIX: Error at line',i + return +993 info=993 + write(psb_err_unit,*) 'READ_MATRIX: Memory allocation failure' + return +end subroutine ldmm_mat_read + + +subroutine ldmm_mat_write(a,mtitle,info,iunit,filename) + use psb_base_mod + implicit none + type(psb_ldspmat_type), intent(in) :: a + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer(psb_ipk_) :: iout + + + info = psb_success_ + + if (present(filename)) then + if (filename == '-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call a%print(iout,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + info=901 + write(psb_err_unit,*) 'Error while opening ',filename + return +end subroutine ldmm_mat_write + + diff --git a/util/psb_d_renum_impl.F90 b/util/psb_d_renum_impl.F90 index ad73527ad..bd4664d8a 100644 --- a/util/psb_d_renum_impl.F90 +++ b/util/psb_d_renum_impl.F90 @@ -267,7 +267,7 @@ contains name = 'mat_renum_amd' call psb_erractionsave(err_act) -#if defined(HAVE_AMD) +#if defined(HAVE_AMD) && defined(IPK4) info = psb_success_ nr = a%get_nrows() diff --git a/util/psb_hbio_mod.f90 b/util/psb_hbio_mod.f90 index 834ada0be..01fa4daa3 100644 --- a/util/psb_hbio_mod.f90 +++ b/util/psb_hbio_mod.f90 @@ -33,7 +33,10 @@ module psb_hbio_mod use psb_base_mod, only : psb_ipk_, psb_spk_, psb_dpk_,& & psb_sspmat_type, psb_cspmat_type, & - & psb_dspmat_type, psb_zspmat_type + & psb_dspmat_type, psb_zspmat_type, & + & psb_lsspmat_type, psb_lcspmat_type, & + & psb_ldspmat_type, psb_lzspmat_type + public hb_read, hb_write @@ -78,6 +81,46 @@ module psb_hbio_mod complex(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) character(len=72), optional, intent(out) :: mtitle end subroutine zhb_read + subroutine lshb_read(a, iret, iunit, filename,b,g,x,mtitle) + import :: psb_lsspmat_type, psb_spk_, psb_ipk_ + implicit none + type(psb_lsspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: iret + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + real(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + end subroutine lshb_read + subroutine ldhb_read(a, iret, iunit, filename,b,g,x,mtitle) + import :: psb_ldspmat_type, psb_dpk_, psb_ipk_ + implicit none + type(psb_ldspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: iret + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + real(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + end subroutine ldhb_read + subroutine lchb_read(a, iret, iunit, filename,b,g,x,mtitle) + import :: psb_lcspmat_type, psb_spk_, psb_ipk_ + implicit none + type(psb_lcspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: iret + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + complex(psb_spk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + end subroutine lchb_read + subroutine lzhb_read(a, iret, iunit, filename,b,g,x,mtitle) + import :: psb_lzspmat_type, psb_dpk_, psb_ipk_ + implicit none + type(psb_lzspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: iret + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + complex(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + end subroutine lzhb_read end interface interface hb_write @@ -125,6 +168,50 @@ module psb_hbio_mod character(len=*), optional, intent(in) :: key complex(psb_dpk_), optional :: rhs(:), g(:), x(:) end subroutine zhb_write + subroutine lshb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + import :: psb_lsspmat_type, psb_spk_, psb_ipk_ + implicit none + type(psb_lsspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_spk_), optional :: rhs(:), g(:), x(:) + end subroutine lshb_write + subroutine ldhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + import :: psb_ldspmat_type, psb_dpk_, psb_ipk_ + implicit none + type(psb_ldspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_dpk_), optional :: rhs(:), g(:), x(:) + end subroutine ldhb_write + subroutine lchb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + import :: psb_lcspmat_type, psb_spk_, psb_ipk_ + implicit none + type(psb_lcspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + complex(psb_spk_), optional :: rhs(:), g(:), x(:) + end subroutine lchb_write + subroutine lzhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + import :: psb_lzspmat_type, psb_dpk_, psb_ipk_ + implicit none + type(psb_lzspmat_type), intent(inout) :: a + integer(psb_ipk_), intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + complex(psb_dpk_), optional :: rhs(:), g(:), x(:) + end subroutine lzhb_write end interface end module psb_hbio_mod diff --git a/util/psb_metispart_mod.F90 b/util/psb_metispart_mod.F90 index 13a2292e8..3d8cad2e5 100644 --- a/util/psb_metispart_mod.F90 +++ b/util/psb_metispart_mod.F90 @@ -54,8 +54,9 @@ ! uses information prepared by the previous two subroutines. ! module psb_metispart_mod - use psb_base_mod, only : psb_ipk_, psb_sspmat_type, psb_cspmat_type,& - & psb_dspmat_type, psb_zspmat_type, psb_err_unit, psb_mpik_,& + use psb_base_mod, only : psb_sspmat_type, psb_cspmat_type,& + & psb_dspmat_type, psb_zspmat_type, psb_err_unit, & + & psb_ipk_, psb_lpk_, psb_mpk_, psb_epk_, & & psb_s_csr_sparse_mat, psb_d_csr_sparse_mat, & & psb_c_csr_sparse_mat, psb_z_csr_sparse_mat public part_graph, build_mtpart, distr_mtpart,& @@ -76,7 +77,7 @@ contains subroutine part_graph(global_indx,n,np,pv,nv) implicit none - integer(psb_ipk_), intent(in) :: global_indx, n + integer(psb_lpk_), intent(in) :: global_indx, n integer(psb_ipk_), intent(in) :: np integer(psb_ipk_), intent(out) :: nv integer(psb_ipk_), intent(out) :: pv(*) @@ -101,8 +102,9 @@ contains use psb_base_mod implicit none integer(psb_ipk_) :: root, ictxt - integer(psb_ipk_) :: n, me, np, info - + integer(psb_ipk_) :: me, np, info + integer(psb_lpk_) :: n + call psb_info(ictxt,me,np) if (.not.((root>=0).and.(root 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call acsc%allocate(nrow,ncol,nnzero) + if (ircode /= 0 ) then + write(psb_err_unit,*) 'Memory allocation failed' + goto 993 + end if + + if (present(mtitle)) mtitle=mtitle_ + + + if (psb_tolower(type(1:1)) == 'r') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + call a%mv_from(acsc) + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 + + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + + call a%cscnv(ircode,type='csr') + if (infile /= 5) close(infile) + + return + + ! open failed +901 iret=901 + write(psb_err_unit,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(psb_err_unit,*) 'HB_READ: Unexpected end of file ' + return +993 iret=993 + write(psb_err_unit,*) 'HB_READ: Memory allocation failure' + return +end subroutine lshb_read + +subroutine lshb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_base_mod + implicit none + type(psb_lsspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + real(psb_spk_), optional :: rhs(:), g(:), x(:) + integer(psb_ipk_) :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer(psb_ipk_), parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer(psb_ipk_), parameter :: jval=4,jrhs=4 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + type(psb_ls_csc_sparse_mat) :: acsc + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype*3,type*3 + + integer(psb_ipk_) :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename == '-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + + call acsc%cp_from_fmt(a%a, iret) + if (iret /= 0) return + + + nrow = acsc%get_nrows() + ncol = acsc%get_ncols() + nnzero = acsc%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'RUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acsc%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + + + + + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(psb_err_unit,*) 'Error while opening ',filename + return +end subroutine lshb_write diff --git a/util/psb_s_mat_dist_impl.f90 b/util/psb_s_mat_dist_impl.f90 index 51cb057db..104340eeb 100644 --- a/util/psb_s_mat_dist_impl.f90 +++ b/util/psb_s_mat_dist_impl.f90 @@ -88,11 +88,11 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& ! local variables logical :: use_parts, use_v integer(psb_ipk_) :: np, iam, np_sharing - integer(psb_ipk_) :: i_count, j_count,& - & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& - & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer(psb_ipk_) :: k_count, root, liwork, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act + integer(psb_lpk_) :: i_count, j_count, nrow, ncol, ig integer(psb_ipk_), allocatable :: iwork(:), iwrk2(:) - integer(psb_ipk_), allocatable :: irow(:),icol(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:) real(psb_spk_), allocatable :: val(:) integer(psb_ipk_), parameter :: nb=30 real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 @@ -140,8 +140,7 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=liwork - call psb_errpush(info,name,i_err=int_err,a_err='integer') + call psb_errpush(info,name,i_err=(/liwork/),a_err='integer') goto 9999 endif if (iam == root) then @@ -339,3 +338,319 @@ subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& return end subroutine psb_smatdist + + + +subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& + & info, parts, v, inroot,fmt,mold) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(psb_sspmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! + ! type(psb_sspmat_type) :: a + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer(psb_ipk_), intent(in) :: global_indx, n, np + ! integer(psb_ipk_), intent(out) :: nv + ! integer(psb_ipk_), intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer(psb_ipk_) :: ictxt + ! on entry: the PSBLAS parallel environment context. + ! + ! type (desc_type) :: desc_a + ! on exit : the updated array descriptor + ! + ! integer(psb_ipk_), optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + use psb_mat_mod + implicit none + + ! parameters + type(psb_lsspmat_type) :: a_glob + integer(psb_ipk_) :: ictxt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: inroot + character(len=*), optional :: fmt + class(psb_s_base_sparse_mat), optional :: mold + procedure(psb_parts), optional :: parts + integer(psb_ipk_), optional :: v(:) + + ! local variables + logical :: use_parts, use_v + integer(psb_ipk_) :: np, iam, np_sharing, root, iproc + integer(psb_ipk_) :: err_act, il, inz + integer(psb_lpk_) :: k_count, liwork, nnzero, nrhs,& + & i, ll, nz, isize, nnr, err + integer(psb_lpk_) :: i_count, j_count, nrow, ncol, ig + integer(psb_ipk_), allocatable :: iwork(:), iwrk2(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:) + real(psb_spk_), allocatable :: val(:) + integer(psb_ipk_), parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = psb_success_ + err = 0 + name = 'psb_s_mat_dist' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + nrow = a_glob%get_nrows() + ncol = a_glob%get_ncols() + if (nrow /= ncol) then + write(psb_err_unit,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = a_glob%get_nzeros() + nrhs = 1 + endif + + use_parts = present(parts) + use_v = present(v) + if (count((/ use_parts, use_v /)) /= 1) then + info=psb_err_no_optional_arg_ + call psb_errpush(info,name,a_err=" v, parts") + goto 9999 + endif + + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), iwrk2(np),stat = info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,l_err=(/liwork/),a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (use_parts) then + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + else if (use_v) then + call psb_cdall(ictxt,desc_a,info,vg=v) + else + info = -1 + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + inz = ((nnzero+np-1)/np) + call psb_spall(a,desc_a,info,nnz=inz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + if (use_parts) then + call parts(i_count,nrow,np,iwork, np_sharing) + ! + ! np_sharing allows for overlap in the data distribution. + ! If an index is overlapped, then we have to send its row + ! to multiple processes. NOTE: we are assuming the output + ! from PARTS is coherent, otherwise a deadlock is the most + ! likely outcome. + ! + j_count = i_count + if (np_sharing == 1) then + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwrk2, np_sharing) + if (np_sharing /= 1 ) exit + if (iwrk2(1) /= iproc ) exit + end do + end if + else + np_sharing = 1 + j_count = i_count + iproc = v(i_count) + iwork(1:np_sharing) = iproc + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + end if + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= psb_success_) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(psb_err_unit,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + do k_count = 1, np_sharing + iproc = iwork(k_count) + + if (iproc == iam) then + il = ll + call psb_spins(il,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + end do + else if (iam /= root) then + + do k_count = 1, np_sharing + iproc = iwork(k_count) + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(psb_err_unit,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_snd(ictxt,ll,root) + il = ll + call psb_spins(il,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + end do + endif + i_count = j_count + end do + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) + t3 = psb_wtime() + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(psb_out_unit,*) 'descriptor assembly: ',t1-t0 + write(psb_out_unit,*) 'sparse matrix assembly: ',t3-t2 + end if + + + + deallocate(val,irow,icol,iwork,iwrk2,stat=info) + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lsmatdist diff --git a/util/psb_s_mat_dist_mod.f90 b/util/psb_s_mat_dist_mod.f90 index e1f0675b6..3b73e5f8c 100644 --- a/util/psb_s_mat_dist_mod.f90 +++ b/util/psb_s_mat_dist_mod.f90 @@ -31,7 +31,8 @@ ! module psb_s_mat_dist_mod use psb_base_mod, only : psb_ipk_, psb_spk_, psb_desc_type, psb_parts, & - & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_vect_type + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_vect_type, & + & psb_lsspmat_type interface psb_matdist subroutine psb_smatdist(a_glob, a, ictxt, desc_a,& @@ -91,6 +92,64 @@ module psb_s_mat_dist_mod procedure(psb_parts), optional :: parts integer(psb_ipk_), optional :: v(:) end subroutine psb_smatdist + subroutine psb_lsmatdist(a_glob, a, ictxt, desc_a,& + & info, parts, v, inroot,fmt,mold) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(psb_lsspmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! + ! type(psb_sspmat_type) :: a + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer(psb_ipk_), intent(in) :: global_indx, n, np + ! integer(psb_ipk_), intent(out) :: nv + ! integer(psb_ipk_), intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer(psb_ipk_) :: ictxt + ! on entry: the PSBLAS parallel environment context. + ! + ! type (desc_type) :: desc_a + ! on exit : the updated array descriptor + ! + ! + ! integer(psb_ipk_), optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + import :: psb_ipk_, psb_sspmat_type, psb_spk_, psb_desc_type,& + & psb_s_base_sparse_mat, psb_s_vect_type, psb_parts, & + & psb_lsspmat_type + implicit none + + ! parameters + type(psb_lsspmat_type) :: a_glob + integer(psb_ipk_) :: ictxt + type(psb_sspmat_type) :: a + type(psb_desc_type) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: inroot + character(len=*), optional :: fmt + class(psb_s_base_sparse_mat), optional :: mold + procedure(psb_parts), optional :: parts + integer(psb_ipk_), optional :: v(:) + end subroutine psb_lsmatdist end interface end module psb_s_mat_dist_mod diff --git a/util/psb_s_mmio_impl.f90 b/util/psb_s_mmio_impl.f90 index 7f049530b..6fffbd1f1 100644 --- a/util/psb_s_mmio_impl.f90 +++ b/util/psb_s_mmio_impl.f90 @@ -434,3 +434,156 @@ subroutine smm_mat_write(a,mtitle,info,iunit,filename) write(psb_err_unit,*) 'Error while opening ',filename return end subroutine smm_mat_write + +subroutine lsmm_mat_read(a, info, iunit, filename) + use psb_base_mod + implicit none + type(psb_lsspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer(psb_lpk_) :: nrow, ncol, nnzero, i,nzr + integer(psb_ipk_) :: ircode,infile + type(psb_ls_coo_sparse_mat), allocatable :: acoo + + info = psb_success_ + + if (present(filename)) then + if (filename == '-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt) /= 'coordinate')) then + write(psb_err_unit,*) 'READ_MATRIX: input file type not yet supported' + info=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + allocate(acoo, stat=ircode) + if (ircode /= 0) goto 993 + if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),acoo%val(i) + end do + call acoo%set_nzeros(nnzero) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),acoo%val(i) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + info=904 + end if + + + if (infile /= 5) close(infile) + return + + ! open failed +901 info=901 + write(psb_err_unit,*) 'read_matrix: could not open file ',filename,' for input' + return +902 info=902 + write(psb_err_unit,*) 'READ_MATRIX: Unexpected end of file ' + return +905 info=905 + write(psb_err_unit,*) 'READ_MATRIX: Error at line',i + return +993 info=993 + write(psb_err_unit,*) 'READ_MATRIX: Memory allocation failure' + return +end subroutine lsmm_mat_read + + +subroutine lsmm_mat_write(a,mtitle,info,iunit,filename) + use psb_base_mod + implicit none + type(psb_lsspmat_type), intent(in) :: a + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer(psb_ipk_) :: iout + + + info = psb_success_ + + if (present(filename)) then + if (filename == '-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call a%print(iout,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + info=901 + write(psb_err_unit,*) 'Error while opening ',filename + return +end subroutine lsmm_mat_write diff --git a/util/psb_s_renum_impl.F90 b/util/psb_s_renum_impl.F90 index 60d3ec9cc..008bbbb02 100644 --- a/util/psb_s_renum_impl.F90 +++ b/util/psb_s_renum_impl.F90 @@ -268,7 +268,7 @@ contains name = 'mat_renum_amd' call psb_erractionsave(err_act) -#if defined(HAVE_AMD) +#if defined(HAVE_AMD) && defined(IPK4) info = psb_success_ nr = a%get_nrows() diff --git a/util/psb_z_hbio_impl.f90 b/util/psb_z_hbio_impl.f90 index 15dedda5d..eacf427dc 100644 --- a/util/psb_z_hbio_impl.f90 +++ b/util/psb_z_hbio_impl.f90 @@ -349,6 +349,336 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) + if (iout /= 6) close(iout) + + + return + +901 continue + iret=901 + write(psb_err_unit,*) 'Error while opening ',filename + return +end subroutine zhb_write + +subroutine lzhb_read(a, iret, iunit, filename,b,g,x,mtitle) + use psb_base_mod + implicit none + type(psb_lzspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: iret + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + complex(psb_dpk_), optional, allocatable, intent(out) :: b(:,:), g(:,:), x(:,:) + character(len=72), optional, intent(out) :: mtitle + + character :: rhstype*3,type*3,key*8 + character(len=72) :: mtitle_ + character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20 + integer(psb_lpk_) :: indcrd, ptrcrd, totcrd,& + & valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix + type(psb_lz_csc_sparse_mat) :: acsc + type(psb_lz_coo_sparse_mat) :: acoo + integer(psb_ipk_) :: ircode, infile, info + integer(psb_lpk_) :: i,nzr + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + iret = 0 + ircode = 0 + if (present(filename)) then + if (filename == '-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix + + call acsc%allocate(nrow,ncol,nnzero) + if (ircode /= 0 ) then + write(psb_err_unit,*) 'Memory allocation failed' + goto 993 + end if + + if (present(mtitle)) mtitle=mtitle_ + + + if (psb_tolower(type(1:1)) == 'c') then + if (psb_tolower(type(2:2)) == 'u') then + + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + call a%mv_from(acsc) + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + else if (psb_tolower(type(2:2)) == 's') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 + + else if (psb_tolower(type(2:2)) == 'h') then + + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + + read (infile,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + read (infile,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) read (infile,fmt=valfmt) (acsc%val(i),i=1,nnzero) + + + if (present(b)) then + if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,b,info) + read (infile,fmt=rhsfmt) (b(i,1),i=1,nrow) + endif + endif + if (present(g)) then + if ((psb_toupper(rhstype(2:2)) == 'G').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,g,info) + read (infile,fmt=rhsfmt) (g(i,1),i=1,nrow) + endif + endif + if (present(x)) then + if ((psb_toupper(rhstype(3:3)) == 'X').and.(rhscrd > 0)) then + call psb_realloc(nrow,1,x,info) + read (infile,fmt=rhsfmt) (x(i,1),i=1,nrow) + endif + endif + + + call acoo%mv_from_fmt(acsc,info) + call acoo%reallocate(2*nnzero) + ! A is now in COO format + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = conjg(acoo%val(i)) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(ircode) + if (ircode == 0) call a%mv_from(acoo) + if (ircode /= 0) goto 993 + + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + iret=904 + end if + + call a%cscnv(ircode,type='csr') + if (infile /= 5) close(infile) + + return + + ! open failed +901 iret=901 + write(psb_err_unit,*) 'read_matrix: could not open file ',filename,' for input' + return +902 iret=902 + write(psb_err_unit,*) 'HB_READ: Unexpected end of file ' + return +993 iret=993 + write(psb_err_unit,*) 'HB_READ: Memory allocation failure' + return +end subroutine lzhb_read + +subroutine lzhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) + use psb_base_mod + implicit none + type(psb_lzspmat_type), intent(in), target :: a + integer(psb_ipk_), intent(out) :: iret + character(len=*), optional, intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character(len=*), optional, intent(in) :: key + complex(psb_dpk_), optional :: rhs(:), g(:), x(:) + integer(psb_ipk_) :: iout + + character(len=*), parameter:: ptrfmt='(10I8)',indfmt='(10I8)' + integer(psb_ipk_), parameter :: jptr=10,jind=10 + character(len=*), parameter:: valfmt='(4E20.12)',rhsfmt='(4E20.12)' + integer(psb_ipk_), parameter :: jval=2,jrhs=2 + character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)' + character(len=*), parameter :: fmt11='(a3,11x,2i14)' + character(len=*), parameter :: fmt111='(1x,a8,1x,i8,1x,a10)' + + type(psb_lz_csc_sparse_mat) :: acsc + character(len=72) :: mtitle_ + character(len=8) :: key_ + + character :: rhstype*3,type*3 + + integer(psb_ipk_) :: i,indcrd,ptrcrd,rhscrd,totcrd,valcrd,& + & nrow,ncol,nnzero, neltvl, nrhs, nrhsix + + iret = 0 + + if (present(filename)) then + if (filename == '-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + if (present(mtitle)) then + mtitle_ = mtitle + else + mtitle_ = 'Temporary PSBLAS title ' + endif + if (present(key)) then + key_ = key + else + key_ = 'PSBMAT00' + endif + + + call acsc%cp_from_fmt(a%a, iret) + if (iret /= 0) return + + + nrow = acsc%get_nrows() + ncol = acsc%get_ncols() + nnzero = acsc%get_nzeros() + + neltvl = 0 + + ptrcrd = (ncol+1)/jptr + if (mod(ncol+1,jptr) > 0) ptrcrd = ptrcrd + 1 + indcrd = nnzero/jind + if (mod(nnzero,jind) > 0) indcrd = indcrd + 1 + valcrd = nnzero/jval + if (mod(nnzero,jval) > 0) valcrd = valcrd + 1 + rhstype = '' + if (present(rhs)) then + if (size(rhs) 0) rhscrd = rhscrd + 1 + endif + nrhs = 1 + rhstype(1:1) = 'F' + else + rhscrd = 0 + nrhs = 0 + end if + totcrd = ptrcrd + indcrd + valcrd + rhscrd + + nrhsix = nrhs*nrow + + if (present(g)) then + rhstype(2:2) = 'G' + end if + if (present(x)) then + rhstype(3:3) = 'X' + end if + type = 'CUA' + + write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,& + & type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt + if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix + write (iout,fmt=ptrfmt) (acsc%icp(i),i=1,ncol+1) + write (iout,fmt=indfmt) (acsc%ia(i),i=1,nnzero) + if (valcrd > 0) write (iout,fmt=valfmt) (acsc%val(i),i=1,nnzero) + if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow) + if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow) + if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow) if (iout /= 6) close(iout) @@ -360,4 +690,4 @@ subroutine zhb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle) iret=901 write(psb_err_unit,*) 'Error while opening ',filename return -end subroutine zhb_write +end subroutine lzhb_write diff --git a/util/psb_z_mat_dist_impl.f90 b/util/psb_z_mat_dist_impl.f90 index e096c414a..818f28e4c 100644 --- a/util/psb_z_mat_dist_impl.f90 +++ b/util/psb_z_mat_dist_impl.f90 @@ -88,11 +88,11 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& ! local variables logical :: use_parts, use_v integer(psb_ipk_) :: np, iam, np_sharing - integer(psb_ipk_) :: i_count, j_count,& - & k_count, root, liwork, nrow, ncol, nnzero, nrhs,& - & i, ll, nz, isize, iproc, nnr, err, err_act, int_err(5) + integer(psb_ipk_) :: k_count, root, liwork, nnzero, nrhs,& + & i, ll, nz, isize, iproc, nnr, err, err_act + integer(psb_lpk_) :: i_count, j_count, nrow, ncol, ig integer(psb_ipk_), allocatable :: iwork(:), iwrk2(:) - integer(psb_ipk_), allocatable :: irow(:),icol(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:) complex(psb_dpk_), allocatable :: val(:) integer(psb_ipk_), parameter :: nb=30 real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 @@ -140,8 +140,7 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& allocate(iwork(liwork), iwrk2(np),stat = info) if (info /= psb_success_) then info=psb_err_alloc_request_ - int_err(1)=liwork - call psb_errpush(info,name,i_err=int_err,a_err='integer') + call psb_errpush(info,name,i_err=(/liwork/),a_err='integer') goto 9999 endif if (iam == root) then @@ -339,3 +338,319 @@ subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& return end subroutine psb_zmatdist + + + +subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& + & info, parts, v, inroot,fmt,mold) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(psb_zspmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! + ! type(psb_zspmat_type) :: a + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer(psb_ipk_), intent(in) :: global_indx, n, np + ! integer(psb_ipk_), intent(out) :: nv + ! integer(psb_ipk_), intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer(psb_ipk_) :: ictxt + ! on entry: the PSBLAS parallel environment context. + ! + ! type (desc_type) :: desc_a + ! on exit : the updated array descriptor + ! + ! integer(psb_ipk_), optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + use psb_base_mod + use psb_mat_mod + implicit none + + ! parameters + type(psb_lzspmat_type) :: a_glob + integer(psb_ipk_) :: ictxt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: inroot + character(len=*), optional :: fmt + class(psb_z_base_sparse_mat), optional :: mold + procedure(psb_parts), optional :: parts + integer(psb_ipk_), optional :: v(:) + + ! local variables + logical :: use_parts, use_v + integer(psb_ipk_) :: np, iam, np_sharing, root, iproc + integer(psb_ipk_) :: err_act, il, inz + integer(psb_lpk_) :: k_count, liwork, nnzero, nrhs,& + & i, ll, nz, isize, nnr, err + integer(psb_lpk_) :: i_count, j_count, nrow, ncol, ig + integer(psb_ipk_), allocatable :: iwork(:), iwrk2(:) + integer(psb_lpk_), allocatable :: irow(:),icol(:) + complex(psb_dpk_), allocatable :: val(:) + integer(psb_ipk_), parameter :: nb=30 + real(psb_dpk_) :: t0, t1, t2, t3, t4, t5 + character(len=20) :: name, ch_err + + info = psb_success_ + err = 0 + name = 'psb_z_mat_dist' + call psb_erractionsave(err_act) + + ! executable statements + if (present(inroot)) then + root = inroot + else + root = psb_root_ + end if + call psb_info(ictxt, iam, np) + if (iam == root) then + nrow = a_glob%get_nrows() + ncol = a_glob%get_ncols() + if (nrow /= ncol) then + write(psb_err_unit,*) 'a rectangular matrix ? ',nrow,ncol + info=-1 + call psb_errpush(info,name) + goto 9999 + endif + nnzero = a_glob%get_nzeros() + nrhs = 1 + endif + + use_parts = present(parts) + use_v = present(v) + if (count((/ use_parts, use_v /)) /= 1) then + info=psb_err_no_optional_arg_ + call psb_errpush(info,name,a_err=" v, parts") + goto 9999 + endif + + ! broadcast informations to other processors + call psb_bcast(ictxt,nrow, root) + call psb_bcast(ictxt,ncol, root) + call psb_bcast(ictxt,nnzero, root) + call psb_bcast(ictxt,nrhs, root) + liwork = max(np, nrow + ncol) + allocate(iwork(liwork), iwrk2(np),stat = info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,l_err=(/liwork/),a_err='integer') + goto 9999 + endif + if (iam == root) then + write (*, fmt = *) 'start matdist',root, size(iwork),& + &nrow, ncol, nnzero,nrhs + endif + if (use_parts) then + call psb_cdall(ictxt,desc_a,info,mg=nrow,parts=parts) + else if (use_v) then + call psb_cdall(ictxt,desc_a,info,vg=v) + else + info = -1 + end if + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_cdall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + inz = ((nnzero+np-1)/np) + call psb_spall(a,desc_a,info,nnz=inz) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spall' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + isize = 3*nb*max(((nnzero+nrow)/nrow),nb) + allocate(val(isize),irow(isize),icol(isize),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + i_count = 1 + + do while (i_count <= nrow) + + if (use_parts) then + call parts(i_count,nrow,np,iwork, np_sharing) + ! + ! np_sharing allows for overlap in the data distribution. + ! If an index is overlapped, then we have to send its row + ! to multiple processes. NOTE: we are assuming the output + ! from PARTS is coherent, otherwise a deadlock is the most + ! likely outcome. + ! + j_count = i_count + if (np_sharing == 1) then + iproc = iwork(1) + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + call parts(j_count,nrow,np,iwrk2, np_sharing) + if (np_sharing /= 1 ) exit + if (iwrk2(1) /= iproc ) exit + end do + end if + else + np_sharing = 1 + j_count = i_count + iproc = v(i_count) + iwork(1:np_sharing) = iproc + do + j_count = j_count + 1 + if (j_count-i_count >= nb) exit + if (j_count > nrow) exit + if (v(j_count) /= iproc ) exit + end do + end if + + ! now we should insert rows i_count..j_count-1 + nnr = j_count - i_count + + if (iam == root) then + + ll = 0 + do i= i_count, j_count-1 + call a_glob%csget(i,i,nz,& + & irow,icol,val,info,nzin=ll,append=.true.) + if (info /= psb_success_) then + if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then + write(psb_err_unit,*) 'Allocation failure? This should not happen!' + end if + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + ll = ll + nz + end do + + do k_count = 1, np_sharing + iproc = iwork(k_count) + + if (iproc == iam) then + il = ll + call psb_spins(il,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_spins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + else + call psb_snd(ictxt,nnr,iproc) + call psb_snd(ictxt,ll,iproc) + call psb_snd(ictxt,irow(1:ll),iproc) + call psb_snd(ictxt,icol(1:ll),iproc) + call psb_snd(ictxt,val(1:ll),iproc) + call psb_rcv(ictxt,ll,iproc) + endif + end do + else if (iam /= root) then + + do k_count = 1, np_sharing + iproc = iwork(k_count) + if (iproc == iam) then + call psb_rcv(ictxt,nnr,root) + call psb_rcv(ictxt,ll,root) + if (ll > size(irow)) then + write(psb_err_unit,*) iam,'need to reallocate ',ll + deallocate(val,irow,icol) + allocate(val(ll),irow(ll),icol(ll),stat=info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='Allocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + endif + call psb_rcv(ictxt,irow(1:ll),root) + call psb_rcv(ictxt,icol(1:ll),root) + call psb_rcv(ictxt,val(1:ll),root) + call psb_snd(ictxt,ll,root) + il = ll + call psb_spins(il,irow,icol,val,a,desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psspins' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + endif + end do + endif + i_count = j_count + end do + + call psb_barrier(ictxt) + t0 = psb_wtime() + call psb_cdasb(desc_a,info) + t1 = psb_wtime() + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='psb_cdasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() + call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=fmt,mold=mold) + t3 = psb_wtime() + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='psb_spasb' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + + if (iam == root) then + write(psb_out_unit,*) 'descriptor assembly: ',t1-t0 + write(psb_out_unit,*) 'sparse matrix assembly: ',t3-t2 + end if + + + + deallocate(val,irow,icol,iwork,iwrk2,stat=info) + if(info /= psb_success_)then + info=psb_err_from_subroutine_ + ch_err='deallocate' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iam == root) write (*, fmt = *) 'end matdist' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ictxt,err_act) + + return + +end subroutine psb_lzmatdist diff --git a/util/psb_z_mat_dist_mod.f90 b/util/psb_z_mat_dist_mod.f90 index 978e22b29..7d7691013 100644 --- a/util/psb_z_mat_dist_mod.f90 +++ b/util/psb_z_mat_dist_mod.f90 @@ -31,7 +31,8 @@ ! module psb_z_mat_dist_mod use psb_base_mod, only : psb_ipk_, psb_dpk_, psb_desc_type, psb_parts, & - & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_vect_type + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_vect_type, & + & psb_lzspmat_type interface psb_matdist subroutine psb_zmatdist(a_glob, a, ictxt, desc_a,& @@ -91,6 +92,64 @@ module psb_z_mat_dist_mod procedure(psb_parts), optional :: parts integer(psb_ipk_), optional :: v(:) end subroutine psb_zmatdist + subroutine psb_lzmatdist(a_glob, a, ictxt, desc_a,& + & info, parts, v, inroot,fmt,mold) + ! + ! an utility subroutine to distribute a matrix among processors + ! according to a user defined data distribution, using + ! sparse matrix subroutines. + ! + ! type(psb_lzspmat) :: a_glob + ! on entry: this contains the global sparse matrix as follows: + ! + ! type(psb_zspmat_type) :: a + ! on exit : this will contain the local sparse matrix. + ! + ! interface parts + ! ! .....user passed subroutine..... + ! subroutine parts(global_indx,n,np,pv,nv) + ! implicit none + ! integer(psb_ipk_), intent(in) :: global_indx, n, np + ! integer(psb_ipk_), intent(out) :: nv + ! integer(psb_ipk_), intent(out) :: pv(*) + ! + ! end subroutine parts + ! end interface + ! on entry: subroutine providing user defined data distribution. + ! for each global_indx the subroutine should return + ! the list pv of all processes owning the row with + ! that index; the list will contain nv entries. + ! usually nv=1; if nv >1 then we have an overlap in the data + ! distribution. + ! + ! integer(psb_ipk_) :: ictxt + ! on entry: the PSBLAS parallel environment context. + ! + ! type (desc_type) :: desc_a + ! on exit : the updated array descriptor + ! + ! + ! integer(psb_ipk_), optional :: inroot + ! on entry: specifies processor holding a_glob. default: 0 + ! on exit : unchanged. + ! + import :: psb_ipk_, psb_zspmat_type, psb_dpk_, psb_desc_type,& + & psb_z_base_sparse_mat, psb_z_vect_type, psb_parts, & + & psb_lzspmat_type + implicit none + + ! parameters + type(psb_lzspmat_type) :: a_glob + integer(psb_ipk_) :: ictxt + type(psb_zspmat_type) :: a + type(psb_desc_type) :: desc_a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional :: inroot + character(len=*), optional :: fmt + class(psb_z_base_sparse_mat), optional :: mold + procedure(psb_parts), optional :: parts + integer(psb_ipk_), optional :: v(:) + end subroutine psb_lzmatdist end interface end module psb_z_mat_dist_mod diff --git a/util/psb_z_mmio_impl.f90 b/util/psb_z_mmio_impl.f90 index 8475d2847..5b348acca 100644 --- a/util/psb_z_mmio_impl.f90 +++ b/util/psb_z_mmio_impl.f90 @@ -462,3 +462,178 @@ subroutine zmm_mat_write(a,mtitle,info,iunit,filename) end subroutine zmm_mat_write +subroutine lzmm_mat_read(a, info, iunit, filename) + use psb_base_mod + implicit none + type(psb_lzspmat_type), intent(out) :: a + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + character :: mmheader*15, fmt*15, object*10, type*10, sym*15 + character(1024) :: line + integer(psb_lpk_) :: nrow, ncol, nnzero, i,nzr + integer(psb_ipk_) :: ircode,infile + type(psb_lz_coo_sparse_mat), allocatable :: acoo + real(psb_dpk_) :: are, aim + info = psb_success_ + + if (present(filename)) then + if (filename == '-') then + infile=5 + else + if (present(iunit)) then + infile=iunit + else + infile=99 + endif + open(infile,file=filename, status='OLD', err=901, action='READ') + endif + else + if (present(iunit)) then + infile=iunit + else + infile=5 + endif + endif + + read(infile,fmt=*,end=902) mmheader, object, fmt, type, sym + + if ( (psb_tolower(object) /= 'matrix').or.(psb_tolower(fmt) /= 'coordinate')) then + write(psb_err_unit,*) 'READ_MATRIX: input file type not yet supported' + info=909 + return + end if + + do + read(infile,fmt='(a)') line + if (line(1:1) /= '%') exit + end do + read(line,fmt=*) nrow,ncol,nnzero + + allocate(acoo, stat=ircode) + if (ircode /= 0) goto 993 + if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'general')) then + call acoo%allocate(nrow,ncol,nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) + end do + call acoo%set_nzeros(nnzero) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'symmetric')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902,err=905) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = acoo%val(i) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else if ((psb_tolower(type) == 'complex').and.(psb_tolower(sym) == 'hermitian')) then + ! we are generally working with non-symmetric matrices, so + ! we de-symmetrize what we are about to read + call acoo%allocate(nrow,ncol,2*nnzero) + do i=1,nnzero + read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),are,aim + acoo%val(i) = cmplx(are,aim,kind=psb_dpk_) + end do + nzr = nnzero + do i=1,nnzero + if (acoo%ia(i) /= acoo%ja(i)) then + nzr = nzr + 1 + acoo%val(nzr) = conjg(acoo%val(i)) + acoo%ia(nzr) = acoo%ja(i) + acoo%ja(nzr) = acoo%ia(i) + end if + end do + call acoo%set_nzeros(nzr) + call acoo%fix(info) + + call a%mv_from(acoo) + call a%cscnv(ircode,type='csr') + + else + write(psb_err_unit,*) 'read_matrix: matrix type not yet supported' + info=904 + end if + if (infile /= 5) close(infile) + return + + ! open failed +901 info=901 + write(psb_err_unit,*) 'read_matrix: could not open file ',filename,' for input' + return +902 info=902 + write(psb_err_unit,*) 'READ_MATRIX: Unexpected end of file ' + return +905 info=905 + write(psb_err_unit,*) 'READ_MATRIX: Error at line',i + return +993 info=993 + write(psb_err_unit,*) 'READ_MATRIX: Memory allocation failure' + return +end subroutine lzmm_mat_read + +subroutine lzmm_mat_write(a,mtitle,info,iunit,filename) + use psb_base_mod + implicit none + type(psb_lzspmat_type), intent(in) :: a + integer(psb_ipk_), intent(out) :: info + character(len=*), intent(in) :: mtitle + integer(psb_ipk_), optional, intent(in) :: iunit + character(len=*), optional, intent(in) :: filename + integer(psb_ipk_) :: iout + + + info = psb_success_ + + if (present(filename)) then + if (filename == '-') then + iout=6 + else + if (present(iunit)) then + iout = iunit + else + iout=99 + endif + open(iout,file=filename, err=901, action='WRITE') + endif + else + if (present(iunit)) then + iout = iunit + else + iout=6 + endif + endif + + call a%print(iout,head=mtitle) + + if (iout /= 6) close(iout) + + + return + +901 continue + info=901 + write(psb_err_unit,*) 'Error while opening ',filename + return +end subroutine lzmm_mat_write + diff --git a/util/psb_z_renum_impl.F90 b/util/psb_z_renum_impl.F90 index 7b212aca7..aa8f6b721 100644 --- a/util/psb_z_renum_impl.F90 +++ b/util/psb_z_renum_impl.F90 @@ -267,7 +267,7 @@ contains name = 'mat_renum_amd' call psb_erractionsave(err_act) -#if defined(HAVE_AMD) +#if defined(HAVE_AMD) && defined(IPK4) info = psb_success_ nr = a%get_nrows()
          6. $x_i, y$ Subroutine