mirror of
https://github.com/sfilippone/amg4psblas.git
synced 2026-10-09 15:41:46 +00:00
Compare commits
169
Commits
| Author | SHA1 | Date | |
|---|---|---|---|
 sfilippone
|
c1e8bc0c57 | ||
|
sfilippone
|
2f5072166d | ||
|
sfilippone
|
89e2d53e8b | ||
|
sfilippone
|
bfe0a32e09 | ||
|
sfilippone
|
e88d176fed | ||
|
sfilippone
|
c96727a97c | ||
|
sfilippone
|
6362db0cc5 | ||
|
sfilippone
|
9239b16175 | ||
|
sfilippone
|
96a700cb9d | ||
|
sfilippone
|
41d91120d4 | ||
|
sfilippone
|
5d20407b15 | ||
|
sfilippone
|
322e3f65d1 | ||
|
sfilippone
|
3ff1ad9372 | ||
|
sfilippone
|
818ead5878 | ||
|
sfilippone
|
803d311d1c | ||
|
sfilippone
|
677e4fe6bc | ||
|
sfilippone
|
02a83575a2 | ||
|
sfilippone
|
cfbec1f6ea | ||
|
sfilippone
|
e11a134a1f | ||
|
sfilippone
|
6d05120930 | ||
|
sfilippone
|
bd2d1e3b26 | ||
|
sfilippone
|
67594f8b07 | ||
|
sfilippone
|
301fb57bb1 | ||
|
sfilippone
|
13eee99ea3 | ||
|
sfilippone
|
fb802c62cd | ||
 Salvatore Filippone
|
897c5229a6 | ||
|
Salvatore Filippone
|
ab5eaac5ed | ||
|
sfilippone
|
234071869d | ||
|
sfilippone
|
3e3b343131 | ||
 Cirdans-Home
|
5790aa0cbd | ||
|
Cirdans-Home
|
a17f503486 | ||
|
Cirdans-Home
|
74dccb6c44 | ||
|
sfilippone
|
e83bde6896 | ||
|
Salvatore Filippone
|
83d435b49e | ||
|
Salvatore Filippone
|
af3fda9690 | ||
|
Salvatore Filippone
|
678237cf29 | ||
|
Salvatore Filippone
|
3671285c7a | ||
|
sfilippone
|
a747cc6abb | ||
 Cirdans-Home
|
d385d99e71 | ||
|
Salvatore Filippone
|
4e6e3d5f09 | ||
|
Salvatore Filippone
|
7c48b96936 | ||
|
Salvatore Filippone
|
12478a2fff | ||
|
Cirdans-Home
|
ea8974f88c | ||
|
Cirdans-Home
|
54d608d2dd | ||
|
sfilippone
|
47bafd7fe7 | ||
|
sfilippone
|
ccef858192 | ||
|
sfilippone
|
30a5c7be03 | ||
|
sfilippone
|
737ebb9a96 | ||
|
sfilippone
|
dc15b931a0 | ||
|
sfilippone
|
23aabd794d | ||
|
sfilippone
|
a67454ef5c | ||
|
sfilippone
|
79317cb392 | ||
|
sfilippone
|
847ed6ae60 | ||
|
sfilippone
|
6ad82037c5 | ||
|
sfilippone
|
bee9d63e9c | ||
|
sfilippone
|
bb262275a1 | ||
|
sfilippone
|
14cd4cde76 | ||
|
sfilippone
|
ec9fcb1bcc | ||
|
sfilippone
|
2dd1cbd3dc | ||
|
sfilippone
|
ea2f75776c | ||
|
sfilippone
|
1dcb542e4a | ||
|
sfilippone
|
84ea60c94c | ||
|
sfilippone
|
e8b50152fa | ||
|
sfilippone
|
e6894501dd | ||
|
sfilippone
|
975fc6265f | ||
|
Salvatore Filippone
|
a97f56d673 | ||
|
sfilippone
|
b1f05482a6 | ||
|
sfilippone
|
fb490cee7e | ||
|
Salvatore Filippone
|
24c85c7114 | ||
|
sfilippone
|
53998a1da9 | ||
|
sfilippone
|
0bcc9d7b55 | ||
|
sfilippone
|
11421f53a2 | ||
|
sfilippone
|
d33bcfe107 | ||
|
sfilippone
|
5bcd36f394 | ||
|
sfilippone
|
73495edf09 | ||
|
sfilippone
|
9e82d2e311 | ||
|
sfilippone
|
c1ecb4ebec | ||
|
sfilippone
|
e78449d0f5 | ||
|
sfilippone
|
e3de565b6d | ||
|
sfilippone
|
7b9c722a1a | ||
|
sfilippone
|
2fd718be6f | ||
|
sfilippone
|
3a5e73e4c8 | ||
|
sfilippone
|
494b8b925f | ||
|
sfilippone
|
73e5d49913 | ||
|
Salvatore Filippone
|
a612cea167 | ||
|
Salvatore Filippone
|
ebe9b45177 | ||
|
Salvatore Filippone
|
32994c7ce8 | ||
|
Salvatore Filippone
|
d59c9e6c0a | ||
|
Salvatore Filippone
|
0d624df346 | ||
 StefanoPetrilli
|
6414d3aef3 | ||
|
StefanoPetrilli
|
a259e8ab53 | ||
|
StefanoPetrilli
|
500403dbda | ||
|
StefanoPetrilli
|
066c1a5e62 | ||
|
StefanoPetrilli
|
1ab166b38b | ||
|
StefanoPetrilli
|
5efee20041 | ||
|
StefanoPetrilli
|
aa45e2fe93 | ||
|
StefanoPetrilli
|
e328f3969c | ||
|
StefanoPetrilli
|
9d1a416f99 | ||
|
StefanoPetrilli
|
9b065602a8 | ||
|
StefanoPetrilli
|
abf258e2e8 | ||
|
StefanoPetrilli
|
cdf92ea2b2 | ||
|
StefanoPetrilli
|
22d9baf296 | ||
|
StefanoPetrilli
|
44f174a571 | ||
|
StefanoPetrilli
|
3e945c75b4 | ||
|
StefanoPetrilli
|
a71fe82752 | ||
|
StefanoPetrilli
|
4f07a70ed1 | ||
|
StefanoPetrilli
|
cb660e044d | ||
|
StefanoPetrilli
|
d24c8c2d46 | ||
|
StefanoPetrilli
|
9ab54adf3f | ||
|
StefanoPetrilli
|
71d4cdc319 | ||
|
StefanoPetrilli
|
1374f21ba8 | ||
|
StefanoPetrilli
|
a9bb6b26fa | ||
|
StefanoPetrilli
|
561cadee0f | ||
|
StefanoPetrilli
|
5ca78fb871 | ||
|
StefanoPetrilli
|
f17082b337 | ||
|
StefanoPetrilli
|
1ea1be33ba | ||
|
StefanoPetrilli
|
47c6f4f2f8 | ||
|
StefanoPetrilli
|
dc1675766f | ||
|
StefanoPetrilli
|
ccac816f52 | ||
|
StefanoPetrilli
|
c7e8193514 | ||
|
StefanoPetrilli
|
36bd3a51a2 | ||
|
StefanoPetrilli
|
32777cc15c | ||
|
StefanoPetrilli
|
64c23f93f8 | ||
|
StefanoPetrilli
|
d19443052d | ||
|
StefanoPetrilli
|
df1e4a4616 | ||
|
StefanoPetrilli
|
3de1e607eb | ||
|
StefanoPetrilli
|
9b13aef1ce | ||
|
StefanoPetrilli
|
6dcae6d0c1 | ||
|
StefanoPetrilli
|
63b7602d3a | ||
|
StefanoPetrilli
|
b66de7f25c | ||
|
StefanoPetrilli
|
46047b2202 | ||
|
StefanoPetrilli
|
7cfe198d0f | ||
|
StefanoPetrilli
|
1aca17cd44 | ||
|
StefanoPetrilli
|
ea040ae5ee | ||
|
StefanoPetrilli
|
7741abd45d | ||
|
StefanoPetrilli
|
b5e52d31f5 | ||
|
StefanoPetrilli
|
deab695294 | ||
|
StefanoPetrilli
|
a54f084ffb | ||
|
StefanoPetrilli
|
bf0532867d | ||
|
StefanoPetrilli
|
2044c5c8eb | ||
|
StefanoPetrilli
|
f38f3cf09a | ||
|
StefanoPetrilli
|
6fd571ecb2 | ||
|
StefanoPetrilli
|
bf35c1659b | ||
|
StefanoPetrilli
|
b2230a6d6d | ||
|
StefanoPetrilli
|
6c20cd7819 | ||
|
StefanoPetrilli
|
f921aa47c4 | ||
|
StefanoPetrilli
|
532701031e | ||
|
StefanoPetrilli
|
b079d71f30 | ||
|
StefanoPetrilli
|
e2ca97ca47 | ||
|
StefanoPetrilli
|
5bc4f2a080 | ||
|
StefanoPetrilli
|
2c8dc2ffdd | ||
|
StefanoPetrilli
|
f3d7b3ab5e | ||
|
StefanoPetrilli
|
766ef320c2 | ||
|
StefanoPetrilli
|
002239f5b6 | ||
|
StefanoPetrilli
|
70b7c4db55 | ||
|
StefanoPetrilli
|
2cac21b345 | ||
|
StefanoPetrilli
|
6180f29f39 | ||
|
StefanoPetrilli
|
b4bfdd83e5 | ||
|
StefanoPetrilli
|
1140669ea7 | ||
|
StefanoPetrilli
|
919e2a2918 | ||
|
StefanoPetrilli
|
baffff3d93 | ||
|
StefanoPetrilli
|
25a603debe | ||
|
StefanoPetrilli
|
a20f0d47e7 | ||
|
StefanoPetrilli
|
76e04ee997 | ||
|
StefanoPetrilli
|
0a8debe43a | ||
|
StefanoPetrilli
|
8f6dc5fac2 | ||
|
StefanoPetrilli
|
7d40fde21d | ||
|
StefanoPetrilli
|
1760afbe97 | ||
|
StefanoPetrilli
|
60f90804d5 |
+1
-1
@@ -75,7 +75,7 @@ CDEFINES=$(AMGCDEFINES)
|
||||
AMGFDEFINES=@AMGFDEFINES@ $(PSBFDEFINES)
|
||||
FDEFINES=$(AMGFDEFINES)
|
||||
|
||||
CXXDEFINES=@AMGCXXDEFINES@
|
||||
CXXDEFINES=@AMGCXXDEFINES@ $(PSBCXXDEFINES)
|
||||
|
||||
@COMPILERULES@
|
||||
|
||||
|
||||
@@ -1,4 +1,3 @@
|
||||
|
||||
AMG4PSBLAS
|
||||
Algebraic Multigrid Package based on PSBLAS (Parallel Sparse BLAS version 3.8)
|
||||
|
||||
|
||||
+12
-9
@@ -9,9 +9,10 @@ FINCLUDES=$(FMFLAG)$(HERE) $(FMFLAG)$(INCDIR) $(PSBLAS_INCLUDES)
|
||||
|
||||
DMODOBJS=amg_d_prec_type.o \
|
||||
amg_d_inner_mod.o amg_d_ilu_solver.o amg_d_diag_solver.o amg_d_jac_smoother.o amg_d_as_smoother.o \
|
||||
amg_d_poly_smoother.o amg_d_poly_coeff_mod.o\
|
||||
amg_d_umf_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o amg_d_id_solver.o\
|
||||
amg_d_base_solver_mod.o amg_d_base_smoother_mod.o amg_d_onelev_mod.o \
|
||||
amg_d_gs_solver.o amg_d_mumps_solver.o \
|
||||
amg_d_gs_solver.o amg_d_mumps_solver.o amg_d_jac_solver.o \
|
||||
amg_d_base_aggregator_mod.o \
|
||||
amg_d_dec_aggregator_mod.o amg_d_symdec_aggregator_mod.o \
|
||||
amg_d_ainv_solver.o amg_d_base_ainv_mod.o \
|
||||
@@ -20,9 +21,9 @@ DMODOBJS=amg_d_prec_type.o \
|
||||
|
||||
SMODOBJS=amg_s_prec_type.o amg_s_ilu_fact_mod.o \
|
||||
amg_s_inner_mod.o amg_s_ilu_solver.o amg_s_diag_solver.o amg_s_jac_smoother.o amg_s_as_smoother.o \
|
||||
amg_s_slu_solver.o amg_s_id_solver.o\
|
||||
amg_s_poly_smoother.o amg_s_slu_solver.o amg_s_id_solver.o\
|
||||
amg_s_base_solver_mod.o amg_s_base_smoother_mod.o amg_s_onelev_mod.o \
|
||||
amg_s_gs_solver.o amg_s_mumps_solver.o \
|
||||
amg_s_gs_solver.o amg_s_mumps_solver.o amg_s_jac_solver.o \
|
||||
amg_s_base_aggregator_mod.o \
|
||||
amg_s_dec_aggregator_mod.o amg_s_symdec_aggregator_mod.o \
|
||||
amg_s_ainv_solver.o amg_s_base_ainv_mod.o \
|
||||
@@ -33,7 +34,7 @@ ZMODOBJS=amg_z_prec_type.o amg_z_ilu_fact_mod.o \
|
||||
amg_z_inner_mod.o amg_z_ilu_solver.o amg_z_diag_solver.o amg_z_jac_smoother.o amg_z_as_smoother.o \
|
||||
amg_z_umf_solver.o amg_z_slu_solver.o amg_z_sludist_solver.o amg_z_id_solver.o\
|
||||
amg_z_base_solver_mod.o amg_z_base_smoother_mod.o amg_z_onelev_mod.o \
|
||||
amg_z_gs_solver.o amg_z_mumps_solver.o \
|
||||
amg_z_gs_solver.o amg_z_mumps_solver.o amg_z_jac_solver.o \
|
||||
amg_z_base_aggregator_mod.o \
|
||||
amg_z_dec_aggregator_mod.o amg_z_symdec_aggregator_mod.o \
|
||||
amg_z_ainv_solver.o amg_z_base_ainv_mod.o \
|
||||
@@ -43,7 +44,7 @@ CMODOBJS=amg_c_prec_type.o amg_c_ilu_fact_mod.o \
|
||||
amg_c_inner_mod.o amg_c_ilu_solver.o amg_c_diag_solver.o amg_c_jac_smoother.o amg_c_as_smoother.o \
|
||||
amg_c_slu_solver.o amg_c_id_solver.o\
|
||||
amg_c_base_solver_mod.o amg_c_base_smoother_mod.o amg_c_onelev_mod.o \
|
||||
amg_c_gs_solver.o amg_c_mumps_solver.o \
|
||||
amg_c_gs_solver.o amg_c_mumps_solver.o amg_c_jac_solver.o \
|
||||
amg_c_base_aggregator_mod.o \
|
||||
amg_c_dec_aggregator_mod.o amg_c_symdec_aggregator_mod.o \
|
||||
amg_c_ainv_solver.o amg_c_base_ainv_mod.o \
|
||||
@@ -155,7 +156,7 @@ amg_z_base_ainv_mod.o: amg_z_base_solver_mod.o amg_base_ainv_mod.o
|
||||
amg_s_base_solver_mod.o amg_d_base_solver_mod.o amg_c_base_solver_mod.o amg_z_base_solver_mod.o: amg_base_prec_type.o
|
||||
|
||||
amg_d_mumps_solver.o amg_d_gs_solver.o amg_d_id_solver.o amg_d_sludist_solver.o amg_d_slu_solver.o \
|
||||
amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o: amg_d_base_solver_mod.o amg_d_prec_type.o
|
||||
amg_d_umf_solver.o amg_d_diag_solver.o amg_d_ilu_solver.o amg_d_jac_solver.o: amg_d_base_solver_mod.o amg_d_prec_type.o
|
||||
|
||||
#amg_d_ilu_fact_mod.o: amg_base_prec_type.o amg_d_base_solver_mod.o
|
||||
#amg_d_ilu_solver.o amg_d_iluk_fact.o: amg_d_ilu_fact_mod.o
|
||||
@@ -164,9 +165,11 @@ amg_d_jac_smoother.o: amg_d_diag_solver.o
|
||||
amg_dprecinit.o amg_dprecset.o: amg_d_diag_solver.o amg_d_ilu_solver.o \
|
||||
amg_d_umf_solver.o amg_d_as_smoother.o amg_d_jac_smoother.o \
|
||||
amg_d_id_solver.o amg_d_slu_solver.o amg_d_sludist_solver.o
|
||||
amg_d_poly_smoother.o: amg_d_base_smoother_mod.o amg_d_poly_coeff_mod.o
|
||||
amg_s_poly_smoother.o: amg_s_base_smoother_mod.o amg_d_poly_coeff_mod.o
|
||||
|
||||
amg_s_mumps_solver.o amg_s_gs_solver.o amg_s_id_solver.o amg_s_slu_solver.o \
|
||||
amg_s_diag_solver.o amg_s_ilu_solver.o: amg_s_base_solver_mod.o amg_s_prec_type.o
|
||||
amg_s_diag_solver.o amg_s_ilu_solver.o amg_s_jac_solver.o: amg_s_base_solver_mod.o amg_s_prec_type.o
|
||||
amg_s_ilu_fact_mod.o: amg_base_prec_type.o amg_s_base_solver_mod.o
|
||||
amg_s_ilu_solver.o amg_s_iluk_fact.o: amg_s_ilu_fact_mod.o
|
||||
amg_s_as_smoother.o amg_s_jac_smoother.o: amg_s_base_smoother_mod.o
|
||||
@@ -176,7 +179,7 @@ amg_sprecinit.o amg_sprecset.o: amg_s_diag_solver.o amg_s_ilu_solver.o \
|
||||
amg_s_id_solver.o amg_s_slu_solver.o
|
||||
|
||||
amg_z_mumps_solver.o amg_z_gs_solver.o amg_z_id_solver.o amg_z_sludist_solver.o amg_z_slu_solver.o \
|
||||
amg_z_umf_solver.o amg_z_diag_solver.o amg_z_ilu_solver.o: amg_z_base_solver_mod.o amg_z_prec_type.o
|
||||
amg_z_umf_solver.o amg_z_diag_solver.o amg_z_ilu_solver.o amg_z_jac_solver.o: amg_z_base_solver_mod.o amg_z_prec_type.o
|
||||
amg_z_ilu_fact_mod.o: amg_base_prec_type.o amg_z_base_solver_mod.o
|
||||
amg_z_ilu_solver.o amg_z_iluk_fact.o: amg_z_ilu_fact_mod.o
|
||||
amg_z_as_smoother.o amg_z_jac_smoother.o: amg_z_base_smoother_mod.o
|
||||
@@ -186,7 +189,7 @@ amg_zprecinit.o amg_zprecset.o: amg_z_diag_solver.o amg_z_ilu_solver.o \
|
||||
amg_z_id_solver.o amg_z_slu_solver.o amg_z_sludist_solver.o
|
||||
|
||||
amg_c_mumps_solver.o amg_c_gs_solver.o amg_c_id_solver.o amg_c_sludist_solver.o amg_c_slu_solver.o \
|
||||
amg_c_diag_solver.o amg_c_ilu_solver.o: amg_c_base_solver_mod.o amg_c_prec_type.o
|
||||
amg_c_diag_solver.o amg_c_ilu_solver.o amg_c_jac_solver.o: amg_c_base_solver_mod.o amg_c_prec_type.o
|
||||
amg_c_ilu_fact_mod.o: amg_base_prec_type.o amg_c_base_solver_mod.o
|
||||
amg_c_ilu_solver.o amg_c_iluk_fact.o: amg_c_ilu_fact_mod.o
|
||||
amg_c_as_smoother.o amg_c_jac_smoother.o: amg_c_base_smoother_mod.o
|
||||
|
||||
@@ -215,7 +215,8 @@ module amg_base_prec_type
|
||||
integer(psb_ipk_), parameter :: amg_fbgs_ = 6
|
||||
integer(psb_ipk_), parameter :: amg_l1_gs_ = 7
|
||||
integer(psb_ipk_), parameter :: amg_l1_fbgs_ = 8
|
||||
integer(psb_ipk_), parameter :: amg_max_prec_ = 8
|
||||
integer(psb_ipk_), parameter :: amg_poly_ = 9
|
||||
integer(psb_ipk_), parameter :: amg_max_prec_ = 9
|
||||
!
|
||||
! Constants for pre/post signaling. Now only used internally
|
||||
!
|
||||
@@ -233,9 +234,9 @@ module amg_base_prec_type
|
||||
integer(psb_ipk_), parameter :: amg_diag_scale_ = amg_slv_delta_+1
|
||||
integer(psb_ipk_), parameter :: amg_l1_diag_scale_ = amg_slv_delta_+2
|
||||
integer(psb_ipk_), parameter :: amg_gs_ = amg_slv_delta_+3
|
||||
! !$ integer(psb_ipk_), parameter :: amg_ilu_n_ = amg_slv_delta_+4
|
||||
! !$ integer(psb_ipk_), parameter :: amg_milu_n_ = amg_slv_delta_+5
|
||||
! !$ integer(psb_ipk_), parameter :: amg_ilu_t_ = amg_slv_delta_+6
|
||||
integer(psb_ipk_), parameter :: amg_ilu_n_ = amg_slv_delta_+4
|
||||
integer(psb_ipk_), parameter :: amg_milu_n_ = amg_slv_delta_+5
|
||||
integer(psb_ipk_), parameter :: amg_ilu_t_ = amg_slv_delta_+6
|
||||
integer(psb_ipk_), parameter :: amg_slu_ = amg_slv_delta_+7
|
||||
integer(psb_ipk_), parameter :: amg_umf_ = amg_slv_delta_+8
|
||||
integer(psb_ipk_), parameter :: amg_sludist_ = amg_slv_delta_+9
|
||||
@@ -319,6 +320,16 @@ module amg_base_prec_type
|
||||
integer(psb_ipk_), parameter :: amg_distr_mat_ = 0
|
||||
integer(psb_ipk_), parameter :: amg_repl_mat_ = 1
|
||||
integer(psb_ipk_), parameter :: amg_max_coarse_mat_ = amg_repl_mat_
|
||||
!
|
||||
! Legal values for entry: amg_poly_variant_
|
||||
!
|
||||
integer(psb_ipk_), parameter :: amg_poly_lottes_ = 0
|
||||
integer(psb_ipk_), parameter :: amg_poly_lottes_beta_ = 1
|
||||
integer(psb_ipk_), parameter :: amg_poly_new_ = 2
|
||||
integer(psb_ipk_), parameter :: amg_poly_dbg_ = 8
|
||||
|
||||
integer(psb_ipk_), parameter :: amg_poly_rho_est_power_ = 0
|
||||
|
||||
!
|
||||
! Legal values for entry: amg_prec_status_
|
||||
!
|
||||
@@ -390,12 +401,12 @@ module amg_base_prec_type
|
||||
& ml_names(0:7)=(/'none ','additive ',&
|
||||
& 'multiplicative', 'VCycle ','WCycle ',&
|
||||
& 'KCycle ','KCycleSym ','new ML '/)
|
||||
character(len=15), parameter :: &
|
||||
character(len=16), parameter :: &
|
||||
& amg_fact_names(0:amg_max_sub_solve_)=(/&
|
||||
& 'none ','Jacobi ',&
|
||||
& 'L1-Jacobi ','none ','none ',&
|
||||
& 'none ','none ','L1-GS ',&
|
||||
& 'L1-FBGS ','none ','Point Jacobi ',&
|
||||
& 'L1-FBGS ','Polynomial ','none ','Point Jacobi ',&
|
||||
& 'L1-Jacobi ','Gauss-Seidel ','ILU(n) ',&
|
||||
& 'MILU(n) ','ILU(t,n) ',&
|
||||
& 'SuperLU ','UMFPACK LU ',&
|
||||
@@ -457,12 +468,12 @@ contains
|
||||
character(len=*), parameter :: name='amg_stringval'
|
||||
! Local variable
|
||||
integer :: index_tab
|
||||
character(len=15) ::string2
|
||||
character(len=128) ::string2
|
||||
index_tab=index(string,char(9))
|
||||
if (index_tab.NE.0) then
|
||||
string2=string(1:index_tab-1)
|
||||
string2=string(1:index_tab-1)
|
||||
else
|
||||
string2=string
|
||||
string2=string
|
||||
endif
|
||||
select case(psb_toupper(trim(string2)))
|
||||
case('NONE')
|
||||
@@ -482,11 +493,11 @@ contains
|
||||
case('BGS','BWGS')
|
||||
val = amg_bwgs_
|
||||
case('ILU')
|
||||
val = psb_ilu_n_
|
||||
val = amg_ilu_n_
|
||||
case('MILU')
|
||||
val = psb_milu_n_
|
||||
val = amg_milu_n_
|
||||
case('ILUT')
|
||||
val = psb_ilu_t_
|
||||
val = amg_ilu_t_
|
||||
case('MUMPS')
|
||||
val = amg_mumps_
|
||||
case('UMF')
|
||||
@@ -557,6 +568,18 @@ contains
|
||||
val = amg_krm_
|
||||
case('AS')
|
||||
val = amg_as_
|
||||
case('POLY')
|
||||
val = amg_poly_
|
||||
case('POLY_LOTTES')
|
||||
val = amg_poly_lottes_
|
||||
case('POLY_LOTTES_BETA')
|
||||
val = amg_poly_lottes_beta_
|
||||
case('POLY_NEW')
|
||||
val = amg_poly_new_
|
||||
case('POLY_DBG')
|
||||
val = amg_poly_dbg_
|
||||
case('POLY_RHO_EST_POWER')
|
||||
val = amg_poly_rho_est_power_
|
||||
case('A_NORMI')
|
||||
val = amg_max_norm_
|
||||
case('USER_CHOICE')
|
||||
@@ -667,10 +690,10 @@ contains
|
||||
& ml_names(pm%ml_cycle)
|
||||
select case (pm%ml_cycle)
|
||||
case (amg_add_ml_)
|
||||
write(iout,*) ' Number of smoother sweeps : ',&
|
||||
write(iout,*) ' Number of smoother sweeps/degree : ',&
|
||||
& pm%sweeps_pre
|
||||
case (amg_mult_ml_,amg_vcycle_ml_, amg_wcycle_ml_, amg_kcycle_ml_, amg_kcyclesym_ml_)
|
||||
write(iout,*) ' Number of smoother sweeps : pre: ',&
|
||||
write(iout,*) ' Number of smoother sweeps/degree : pre: ',&
|
||||
& pm%sweeps_pre ,' post: ', pm%sweeps_post
|
||||
end select
|
||||
|
||||
@@ -1036,8 +1059,8 @@ contains
|
||||
integer(psb_ipk_), intent(in) :: ip
|
||||
logical :: is_legal_ilu_fact
|
||||
|
||||
is_legal_ilu_fact = ((ip==psb_ilu_n_).or.&
|
||||
& (ip==psb_milu_n_).or.(ip==psb_ilu_t_))
|
||||
is_legal_ilu_fact = ((ip==amg_ilu_n_).or.&
|
||||
& (ip==amg_milu_n_).or.(ip==amg_ilu_t_))
|
||||
return
|
||||
end function is_legal_ilu_fact
|
||||
function is_legal_d_omega(ip)
|
||||
|
||||
@@ -234,7 +234,7 @@ contains
|
||||
! Arguments
|
||||
class(amg_c_ilu_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%fact_type = psb_ilu_n_
|
||||
sv%fact_type = amg_ilu_n_
|
||||
sv%fill_in = 0
|
||||
sv%thresh = szero
|
||||
|
||||
@@ -255,13 +255,13 @@ contains
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(sv%fact_type,&
|
||||
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
|
||||
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
|
||||
|
||||
select case(sv%fact_type)
|
||||
case(psb_ilu_n_,psb_milu_n_)
|
||||
case(amg_ilu_n_,amg_milu_n_)
|
||||
call amg_check_def(sv%fill_in,&
|
||||
& 'Level',izero,is_int_non_negative)
|
||||
case(psb_ilu_t_)
|
||||
case(amg_ilu_t_)
|
||||
call amg_check_def(sv%thresh,&
|
||||
& 'Eps',szero,is_legal_s_fact_thrs)
|
||||
end select
|
||||
@@ -439,9 +439,9 @@ contains
|
||||
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
|
||||
& amg_fact_names(sv%fact_type)
|
||||
select case(sv%fact_type)
|
||||
case(psb_ilu_n_,psb_milu_n_)
|
||||
case(amg_ilu_n_,amg_milu_n_)
|
||||
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
|
||||
case(psb_ilu_t_)
|
||||
case(amg_ilu_t_)
|
||||
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
|
||||
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
|
||||
end select
|
||||
@@ -496,7 +496,7 @@ contains
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = psb_ilu_n_
|
||||
val = amg_ilu_n_
|
||||
end function c_ilu_solver_get_id
|
||||
|
||||
function c_ilu_solver_get_wrksize() result(val)
|
||||
|
||||
@@ -0,0 +1,585 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_c_jac_solver_mod.f90
|
||||
!
|
||||
! Module: amg_c_jac_solver_mod
|
||||
!
|
||||
! This module defines:
|
||||
! - the amg_c_jac_solver_type data structure containing the ingredients
|
||||
! for a local Jacobi iteration. The iterations are local to a process
|
||||
! (they operate on the block diagonal).
|
||||
!
|
||||
!
|
||||
module amg_c_jac_solver
|
||||
|
||||
use amg_c_base_solver_mod
|
||||
|
||||
type, extends(amg_c_base_solver_type) :: amg_c_jac_solver_type
|
||||
type(psb_cspmat_type) :: a
|
||||
type(psb_c_vect_type), allocatable :: dv
|
||||
complex(psb_spk_), allocatable :: d(:)
|
||||
integer(psb_ipk_) :: sweeps
|
||||
real(psb_spk_) :: eps
|
||||
contains
|
||||
procedure, pass(sv) :: dump => amg_c_jac_solver_dmp
|
||||
procedure, pass(sv) :: check => c_jac_solver_check
|
||||
procedure, pass(sv) :: clone => amg_c_jac_solver_clone
|
||||
procedure, pass(sv) :: clone_settings => amg_c_jac_solver_clone_settings
|
||||
procedure, pass(sv) :: clear_data => amg_c_jac_solver_clear_data
|
||||
procedure, pass(sv) :: build => amg_c_jac_solver_bld
|
||||
procedure, pass(sv) :: cnv => amg_c_jac_solver_cnv
|
||||
procedure, pass(sv) :: apply_v => amg_c_jac_solver_apply_vect
|
||||
procedure, pass(sv) :: apply_a => amg_c_jac_solver_apply
|
||||
procedure, pass(sv) :: free => c_jac_solver_free
|
||||
procedure, pass(sv) :: cseti => c_jac_solver_cseti
|
||||
procedure, pass(sv) :: csetc => c_jac_solver_csetc
|
||||
procedure, pass(sv) :: csetr => c_jac_solver_csetr
|
||||
procedure, pass(sv) :: descr => c_jac_solver_descr
|
||||
procedure, pass(sv) :: default => c_jac_solver_default
|
||||
procedure, pass(sv) :: sizeof => c_jac_solver_sizeof
|
||||
procedure, pass(sv) :: get_nzeros => c_jac_solver_get_nzeros
|
||||
procedure, nopass :: get_wrksz => c_jac_solver_get_wrksize
|
||||
procedure, nopass :: get_fmt => c_jac_solver_get_fmt
|
||||
procedure, nopass :: get_id => c_jac_solver_get_id
|
||||
procedure, nopass :: is_iterative => c_jac_solver_is_iterative
|
||||
end type amg_c_jac_solver_type
|
||||
|
||||
type, extends(amg_c_jac_solver_type) :: amg_c_l1_jac_solver_type
|
||||
contains
|
||||
procedure, pass(sv) :: build => amg_c_l1_jac_solver_bld
|
||||
procedure, pass(sv) :: descr => c_l1_jac_solver_descr
|
||||
procedure, nopass :: get_fmt => c_l1_jac_solver_get_fmt
|
||||
procedure, nopass :: get_id => c_l1_jac_solver_get_id
|
||||
end type amg_c_l1_jac_solver_type
|
||||
|
||||
|
||||
private :: c_jac_solver_bld, c_jac_solver_apply, &
|
||||
& c_jac_solver_free, &
|
||||
& c_jac_solver_descr, c_jac_solver_sizeof, &
|
||||
& c_jac_solver_default, c_jac_solver_dmp, &
|
||||
& c_jac_solver_apply_vect, c_jac_solver_get_nzeros, &
|
||||
& c_jac_solver_get_fmt, c_jac_solver_check,&
|
||||
& c_jac_solver_is_iterative, &
|
||||
& c_jac_solver_get_id, c_jac_solver_get_wrksize
|
||||
|
||||
interface
|
||||
subroutine amg_c_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
type(psb_c_vect_type),intent(inout) :: x
|
||||
type(psb_c_vect_type),intent(inout) :: y
|
||||
complex(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_c_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_c_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_c_jac_solver_apply_vect
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
|
||||
import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
complex(psb_spk_),intent(inout) :: x(:)
|
||||
complex(psb_spk_),intent(inout) :: y(:)
|
||||
complex(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_spk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
complex(psb_spk_),intent(inout), optional :: initu(:)
|
||||
end subroutine amg_c_jac_solver_apply
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_cspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_cspmat_type), intent(in), target, optional :: b
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_c_jac_solver_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_c_l1_jac_solver_type, psb_c_vect_type, psb_spk_, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_cspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_c_l1_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_cspmat_type), intent(in), target, optional :: b
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_c_l1_jac_solver_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_jac_solver_cnv(sv,info,amold,vmold,imold)
|
||||
import :: amg_c_jac_solver_type, psb_spk_, &
|
||||
& psb_c_base_sparse_mat, psb_c_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_c_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_c_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_c_jac_solver_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
|
||||
import :: psb_desc_type, amg_c_jac_solver_type, psb_c_vect_type, psb_spk_, &
|
||||
& psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, &
|
||||
& psb_ipk_
|
||||
implicit none
|
||||
class(amg_c_jac_solver_type), intent(in) :: sv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: solver, global_num
|
||||
end subroutine amg_c_jac_solver_dmp
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_jac_solver_clone(sv,svout,info)
|
||||
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
|
||||
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
|
||||
& amg_c_base_solver_type, amg_c_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_c_jac_solver_clone
|
||||
end interface
|
||||
|
||||
!!$ interface
|
||||
!!$ subroutine amg_c_l1_jac_solver_clone(sv,svout,info)
|
||||
!!$ import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
|
||||
!!$ & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
|
||||
!!$ & amg_c_base_solver_type, amg_c_l1_jac_solver_type, psb_ipk_
|
||||
!!$ Implicit None
|
||||
!!$
|
||||
!!$ ! Arguments
|
||||
!!$ class(amg_c_l1_jac_solver_type), intent(inout) :: sv
|
||||
!!$ class(amg_c_base_solver_type), allocatable, intent(inout) :: svout
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ end subroutine amg_c_l1_jac_solver_clone
|
||||
!!$ end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_jac_solver_clone_settings(sv,svout,info)
|
||||
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
|
||||
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
|
||||
& amg_c_base_solver_type, amg_c_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
class(amg_c_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_c_jac_solver_clone_settings
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_jac_solver_clear_data(sv,info)
|
||||
import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, &
|
||||
& psb_c_vect_type, psb_c_base_vect_type, psb_spk_, &
|
||||
& amg_c_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_c_jac_solver_clear_data
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine c_jac_solver_default(sv)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%sweeps = ione
|
||||
sv%eps = dzero
|
||||
|
||||
return
|
||||
end subroutine c_jac_solver_default
|
||||
|
||||
subroutine c_jac_solver_check(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_jac_solver_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(sv%sweeps,&
|
||||
& 'Jacobi sweeps',ione,is_int_positive)
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine c_jac_solver_check
|
||||
|
||||
subroutine c_jac_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_jac_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SOLVER_SWEEPS')
|
||||
sv%sweeps = val
|
||||
case default
|
||||
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_jac_solver_cseti
|
||||
|
||||
subroutine c_jac_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, ival
|
||||
character(len=20) :: name='c_jac_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
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 c_jac_solver_csetc
|
||||
|
||||
subroutine c_jac_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_jac_solver_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SOLVER_EPS')
|
||||
sv%eps = val
|
||||
case default
|
||||
call sv%amg_c_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_jac_solver_csetr
|
||||
|
||||
subroutine c_jac_solver_free(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='c_jac_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%a%free()
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
if (allocated(sv%d)) deallocate(sv%d)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_jac_solver_free
|
||||
|
||||
subroutine c_jac_solver_descr(sv,info,iout,coarse,prefix)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_c_jac_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if (sv%eps<=dzero) then
|
||||
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',&
|
||||
& sv%sweeps,' sweeps'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',&
|
||||
& sv%eps,' and maxit', sv%sweeps
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_jac_solver_descr
|
||||
|
||||
function c_jac_solver_get_nzeros(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = 0
|
||||
val = val + sv%a%get_nzeros()
|
||||
val = val + sv%dv%get_nrows()
|
||||
|
||||
return
|
||||
end function c_jac_solver_get_nzeros
|
||||
|
||||
function c_jac_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_c_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = psb_sizeof_ip
|
||||
val = val + sv%a%sizeof()
|
||||
val = val + sv%dv%sizeof()
|
||||
|
||||
return
|
||||
end function c_jac_solver_sizeof
|
||||
|
||||
function c_jac_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "Jacobi solver"
|
||||
end function c_jac_solver_get_fmt
|
||||
|
||||
function c_jac_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_jac_
|
||||
end function c_jac_solver_get_id
|
||||
|
||||
!
|
||||
! If this is true, then the solver needs a starting
|
||||
! guess. Currently only handled in JAC smoother.
|
||||
!
|
||||
function c_jac_solver_is_iterative() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function c_jac_solver_is_iterative
|
||||
|
||||
function c_jac_solver_get_wrksize() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = 2
|
||||
end function c_jac_solver_get_wrksize
|
||||
|
||||
subroutine c_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_c_l1_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_c_l1_jac_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if (sv%eps<=dzero) then
|
||||
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',&
|
||||
& sv%sweeps,' sweeps'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',&
|
||||
& sv%eps,' and maxit', sv%sweeps
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine c_l1_jac_solver_descr
|
||||
|
||||
function c_l1_jac_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "L1-Jacobi solver"
|
||||
end function c_l1_jac_solver_get_fmt
|
||||
|
||||
function c_l1_jac_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_l1_jac_
|
||||
end function c_l1_jac_solver_get_id
|
||||
|
||||
end module amg_c_jac_solver
|
||||
@@ -78,7 +78,8 @@ module amg_c_mumps_solver
|
||||
!
|
||||
! Controls to be set before MUMPS instantiation:
|
||||
!
|
||||
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: LOCAL 1==amg_global_solver_: GLOBAL
|
||||
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: 'LOCAL_SOLVER
|
||||
! 1==amg_global_solver_: 'GLOBAL_SOLVER'
|
||||
! IPAR(2) : MUMPS_PRINT_ERR print verbosity (see MUMPS)
|
||||
! IPAR(3) : MUMPS_SYM 0: non-symmetric 2: symmetric
|
||||
integer(psb_ipk_), dimension(3) :: ipar
|
||||
|
||||
@@ -187,6 +187,7 @@ module amg_c_onelev_mod
|
||||
procedure, pass(lv) :: clone => c_base_onelev_clone
|
||||
procedure, pass(lv) :: cnv => amg_c_base_onelev_cnv
|
||||
procedure, pass(lv) :: descr => amg_c_base_onelev_descr
|
||||
procedure, pass(lv) :: memory_use => amg_c_base_onelev_memory_use
|
||||
procedure, pass(lv) :: default => c_base_onelev_default
|
||||
procedure, pass(lv) :: free => amg_c_base_onelev_free
|
||||
procedure, pass(lv) :: free_smoothers => amg_c_base_onelev_free_smoothers
|
||||
@@ -273,6 +274,23 @@ module amg_c_onelev_mod
|
||||
end subroutine amg_c_base_onelev_descr
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
|
||||
import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, &
|
||||
& psb_clinmap_type, psb_spk_, amg_c_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine amg_c_base_onelev_memory_use
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_c_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
import :: amg_c_onelev_type, psb_c_base_vect_type, psb_spk_, &
|
||||
|
||||
@@ -139,6 +139,7 @@ module amg_c_prec_type
|
||||
procedure, pass(prec) :: smoothers_build => amg_c_smoothers_bld
|
||||
procedure, pass(prec) :: smoothers_free => amg_c_smoothers_free
|
||||
procedure, pass(prec) :: descr => amg_cfile_prec_descr
|
||||
procedure, pass(prec) :: memory_use => amg_cfile_prec_memory_use
|
||||
end type amg_cprec_type
|
||||
|
||||
private :: amg_c_dump, amg_c_get_compl, amg_c_cmp_compl,&
|
||||
@@ -170,6 +171,22 @@ module amg_c_prec_type
|
||||
end subroutine amg_cfile_prec_descr
|
||||
end interface
|
||||
|
||||
|
||||
interface amg_memory_use
|
||||
subroutine amg_cfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
|
||||
import :: amg_cprec_type, psb_ipk_
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_cprec_type), intent(in) :: prec
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine amg_cfile_prec_memory_use
|
||||
end interface
|
||||
|
||||
interface amg_sizeof
|
||||
module procedure amg_cprec_sizeof
|
||||
end interface
|
||||
|
||||
@@ -234,7 +234,7 @@ contains
|
||||
! Arguments
|
||||
class(amg_d_ilu_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%fact_type = psb_ilu_n_
|
||||
sv%fact_type = amg_ilu_n_
|
||||
sv%fill_in = 0
|
||||
sv%thresh = dzero
|
||||
|
||||
@@ -255,13 +255,13 @@ contains
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(sv%fact_type,&
|
||||
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
|
||||
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
|
||||
|
||||
select case(sv%fact_type)
|
||||
case(psb_ilu_n_,psb_milu_n_)
|
||||
case(amg_ilu_n_,amg_milu_n_)
|
||||
call amg_check_def(sv%fill_in,&
|
||||
& 'Level',izero,is_int_non_negative)
|
||||
case(psb_ilu_t_)
|
||||
case(amg_ilu_t_)
|
||||
call amg_check_def(sv%thresh,&
|
||||
& 'Eps',dzero,is_legal_d_fact_thrs)
|
||||
end select
|
||||
@@ -439,9 +439,9 @@ contains
|
||||
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
|
||||
& amg_fact_names(sv%fact_type)
|
||||
select case(sv%fact_type)
|
||||
case(psb_ilu_n_,psb_milu_n_)
|
||||
case(amg_ilu_n_,amg_milu_n_)
|
||||
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
|
||||
case(psb_ilu_t_)
|
||||
case(amg_ilu_t_)
|
||||
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
|
||||
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
|
||||
end select
|
||||
@@ -496,7 +496,7 @@ contains
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = psb_ilu_n_
|
||||
val = amg_ilu_n_
|
||||
end function d_ilu_solver_get_id
|
||||
|
||||
function d_ilu_solver_get_wrksize() result(val)
|
||||
|
||||
@@ -0,0 +1,585 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_d_jac_solver_mod.f90
|
||||
!
|
||||
! Module: amg_d_jac_solver_mod
|
||||
!
|
||||
! This module defines:
|
||||
! - the amg_d_jac_solver_type data structure containing the ingredients
|
||||
! for a local Jacobi iteration. The iterations are local to a process
|
||||
! (they operate on the block diagonal).
|
||||
!
|
||||
!
|
||||
module amg_d_jac_solver
|
||||
|
||||
use amg_d_base_solver_mod
|
||||
|
||||
type, extends(amg_d_base_solver_type) :: amg_d_jac_solver_type
|
||||
type(psb_dspmat_type) :: a
|
||||
type(psb_d_vect_type), allocatable :: dv
|
||||
real(psb_dpk_), allocatable :: d(:)
|
||||
integer(psb_ipk_) :: sweeps
|
||||
real(psb_dpk_) :: eps
|
||||
contains
|
||||
procedure, pass(sv) :: dump => amg_d_jac_solver_dmp
|
||||
procedure, pass(sv) :: check => d_jac_solver_check
|
||||
procedure, pass(sv) :: clone => amg_d_jac_solver_clone
|
||||
procedure, pass(sv) :: clone_settings => amg_d_jac_solver_clone_settings
|
||||
procedure, pass(sv) :: clear_data => amg_d_jac_solver_clear_data
|
||||
procedure, pass(sv) :: build => amg_d_jac_solver_bld
|
||||
procedure, pass(sv) :: cnv => amg_d_jac_solver_cnv
|
||||
procedure, pass(sv) :: apply_v => amg_d_jac_solver_apply_vect
|
||||
procedure, pass(sv) :: apply_a => amg_d_jac_solver_apply
|
||||
procedure, pass(sv) :: free => d_jac_solver_free
|
||||
procedure, pass(sv) :: cseti => d_jac_solver_cseti
|
||||
procedure, pass(sv) :: csetc => d_jac_solver_csetc
|
||||
procedure, pass(sv) :: csetr => d_jac_solver_csetr
|
||||
procedure, pass(sv) :: descr => d_jac_solver_descr
|
||||
procedure, pass(sv) :: default => d_jac_solver_default
|
||||
procedure, pass(sv) :: sizeof => d_jac_solver_sizeof
|
||||
procedure, pass(sv) :: get_nzeros => d_jac_solver_get_nzeros
|
||||
procedure, nopass :: get_wrksz => d_jac_solver_get_wrksize
|
||||
procedure, nopass :: get_fmt => d_jac_solver_get_fmt
|
||||
procedure, nopass :: get_id => d_jac_solver_get_id
|
||||
procedure, nopass :: is_iterative => d_jac_solver_is_iterative
|
||||
end type amg_d_jac_solver_type
|
||||
|
||||
type, extends(amg_d_jac_solver_type) :: amg_d_l1_jac_solver_type
|
||||
contains
|
||||
procedure, pass(sv) :: build => amg_d_l1_jac_solver_bld
|
||||
procedure, pass(sv) :: descr => d_l1_jac_solver_descr
|
||||
procedure, nopass :: get_fmt => d_l1_jac_solver_get_fmt
|
||||
procedure, nopass :: get_id => d_l1_jac_solver_get_id
|
||||
end type amg_d_l1_jac_solver_type
|
||||
|
||||
|
||||
private :: d_jac_solver_bld, d_jac_solver_apply, &
|
||||
& d_jac_solver_free, &
|
||||
& d_jac_solver_descr, d_jac_solver_sizeof, &
|
||||
& d_jac_solver_default, d_jac_solver_dmp, &
|
||||
& d_jac_solver_apply_vect, d_jac_solver_get_nzeros, &
|
||||
& d_jac_solver_get_fmt, d_jac_solver_check,&
|
||||
& d_jac_solver_is_iterative, &
|
||||
& d_jac_solver_get_id, d_jac_solver_get_wrksize
|
||||
|
||||
interface
|
||||
subroutine amg_d_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
type(psb_d_vect_type),intent(inout) :: x
|
||||
type(psb_d_vect_type),intent(inout) :: y
|
||||
real(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
type(psb_d_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_d_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_d_jac_solver_apply_vect
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
|
||||
import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
real(psb_dpk_),intent(inout) :: x(:)
|
||||
real(psb_dpk_),intent(inout) :: y(:)
|
||||
real(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
real(psb_dpk_),intent(inout), optional :: initu(:)
|
||||
end subroutine amg_d_jac_solver_apply
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_dspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_dspmat_type), intent(in), target, optional :: b
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_d_jac_solver_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_d_l1_jac_solver_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_dspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_d_l1_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_dspmat_type), intent(in), target, optional :: b
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_d_l1_jac_solver_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_jac_solver_cnv(sv,info,amold,vmold,imold)
|
||||
import :: amg_d_jac_solver_type, psb_dpk_, &
|
||||
& psb_d_base_sparse_mat, psb_d_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_d_jac_solver_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
|
||||
import :: psb_desc_type, amg_d_jac_solver_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, &
|
||||
& psb_ipk_
|
||||
implicit none
|
||||
class(amg_d_jac_solver_type), intent(in) :: sv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: solver, global_num
|
||||
end subroutine amg_d_jac_solver_dmp
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_jac_solver_clone(sv,svout,info)
|
||||
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
|
||||
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
|
||||
& amg_d_base_solver_type, amg_d_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_jac_solver_clone
|
||||
end interface
|
||||
|
||||
!!$ interface
|
||||
!!$ subroutine amg_d_l1_jac_solver_clone(sv,svout,info)
|
||||
!!$ import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
|
||||
!!$ & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
|
||||
!!$ & amg_d_base_solver_type, amg_d_l1_jac_solver_type, psb_ipk_
|
||||
!!$ Implicit None
|
||||
!!$
|
||||
!!$ ! Arguments
|
||||
!!$ class(amg_d_l1_jac_solver_type), intent(inout) :: sv
|
||||
!!$ class(amg_d_base_solver_type), allocatable, intent(inout) :: svout
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ end subroutine amg_d_l1_jac_solver_clone
|
||||
!!$ end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_jac_solver_clone_settings(sv,svout,info)
|
||||
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
|
||||
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
|
||||
& amg_d_base_solver_type, amg_d_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
class(amg_d_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_jac_solver_clone_settings
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_jac_solver_clear_data(sv,info)
|
||||
import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, &
|
||||
& psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, &
|
||||
& amg_d_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_jac_solver_clear_data
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine d_jac_solver_default(sv)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%sweeps = ione
|
||||
sv%eps = dzero
|
||||
|
||||
return
|
||||
end subroutine d_jac_solver_default
|
||||
|
||||
subroutine d_jac_solver_check(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_jac_solver_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(sv%sweeps,&
|
||||
& 'Jacobi sweeps',ione,is_int_positive)
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine d_jac_solver_check
|
||||
|
||||
subroutine d_jac_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_jac_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SOLVER_SWEEPS')
|
||||
sv%sweeps = val
|
||||
case default
|
||||
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_jac_solver_cseti
|
||||
|
||||
subroutine d_jac_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, ival
|
||||
character(len=20) :: name='d_jac_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
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 d_jac_solver_csetc
|
||||
|
||||
subroutine d_jac_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_jac_solver_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SOLVER_EPS')
|
||||
sv%eps = val
|
||||
case default
|
||||
call sv%amg_d_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_jac_solver_csetr
|
||||
|
||||
subroutine d_jac_solver_free(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_jac_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%a%free()
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
if (allocated(sv%d)) deallocate(sv%d)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_jac_solver_free
|
||||
|
||||
subroutine d_jac_solver_descr(sv,info,iout,coarse,prefix)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_d_jac_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if (sv%eps<=dzero) then
|
||||
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',&
|
||||
& sv%sweeps,' sweeps'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',&
|
||||
& sv%eps,' and maxit', sv%sweeps
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_jac_solver_descr
|
||||
|
||||
function d_jac_solver_get_nzeros(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = 0
|
||||
val = val + sv%a%get_nzeros()
|
||||
val = val + sv%dv%get_nrows()
|
||||
|
||||
return
|
||||
end function d_jac_solver_get_nzeros
|
||||
|
||||
function d_jac_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_d_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = psb_sizeof_ip
|
||||
val = val + sv%a%sizeof()
|
||||
val = val + sv%dv%sizeof()
|
||||
|
||||
return
|
||||
end function d_jac_solver_sizeof
|
||||
|
||||
function d_jac_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "Jacobi solver"
|
||||
end function d_jac_solver_get_fmt
|
||||
|
||||
function d_jac_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_jac_
|
||||
end function d_jac_solver_get_id
|
||||
|
||||
!
|
||||
! If this is true, then the solver needs a starting
|
||||
! guess. Currently only handled in JAC smoother.
|
||||
!
|
||||
function d_jac_solver_is_iterative() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function d_jac_solver_is_iterative
|
||||
|
||||
function d_jac_solver_get_wrksize() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = 2
|
||||
end function d_jac_solver_get_wrksize
|
||||
|
||||
subroutine d_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_l1_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_d_l1_jac_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if (sv%eps<=dzero) then
|
||||
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',&
|
||||
& sv%sweeps,' sweeps'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',&
|
||||
& sv%eps,' and maxit', sv%sweeps
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_l1_jac_solver_descr
|
||||
|
||||
function d_l1_jac_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "L1-Jacobi solver"
|
||||
end function d_l1_jac_solver_get_fmt
|
||||
|
||||
function d_l1_jac_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_l1_jac_
|
||||
end function d_l1_jac_solver_get_id
|
||||
|
||||
end module amg_d_jac_solver
|
||||
@@ -143,9 +143,10 @@ contains
|
||||
type(psb_ld_coo_sparse_mat) :: tmpcoo
|
||||
logical :: display_out_, print_out_, reproducible_
|
||||
logical, parameter :: dump=.false., debug=.false., dump_mate=.false., &
|
||||
& debug_ilaggr=.false., debug_sync=.false.
|
||||
& debug_ilaggr=.false., debug_sync=.false., debug_mate=.false.
|
||||
integer(psb_ipk_), save :: idx_bldmtc=-1, idx_phase1=-1, idx_phase2=-1, idx_phase3=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
integer, parameter :: ilaggr_neginit=-1, ilaggr_nonlocal=-2
|
||||
|
||||
ictxt = desc_a%get_ctxt()
|
||||
call psb_info(ictxt,iam,np)
|
||||
@@ -187,7 +188,7 @@ contains
|
||||
call desc_a%l2gip(ilv,info,owned=.false.)
|
||||
|
||||
call psb_geall(ilaggr,desc_a,info)
|
||||
ilaggr = -1
|
||||
ilaggr = ilaggr_neginit
|
||||
call psb_geasb(ilaggr,desc_a,info)
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -213,7 +214,20 @@ contains
|
||||
call psb_barrier(ictxt)
|
||||
if (iam == 0) write(0,*)' out from buildmatching:', info
|
||||
end if
|
||||
|
||||
if (debug_mate) then
|
||||
block
|
||||
integer(psb_lpk_), allocatable :: ckmate(:)
|
||||
allocate(ckmate(nr))
|
||||
ckmate(1:nr) = mate(1:nr)
|
||||
call psb_msort(ckmate(1:nr))
|
||||
do i=1,nr-1
|
||||
if ((ckmate(i)>0) .and. (ckmate(i) == ckmate(i+1))) then
|
||||
write(0,*) iam,' Duplicate mate entry at',i,' :',ckmate(i)
|
||||
end if
|
||||
end do
|
||||
end block
|
||||
end if
|
||||
|
||||
if (info == 0) then
|
||||
if (do_timings) call psb_tic(idx_phase2)
|
||||
if (debug_sync) then
|
||||
@@ -259,7 +273,7 @@ contains
|
||||
cycle
|
||||
else
|
||||
|
||||
if (ilaggr(k) == -1) then
|
||||
if (ilaggr(k) == ilaggr_neginit) then
|
||||
|
||||
wk = w(k)
|
||||
widx = w(idx)
|
||||
@@ -267,7 +281,7 @@ contains
|
||||
nrmagg = wmax*sqrt((wk/wmax)**2+(widx/wmax)**2)
|
||||
if (nrmagg > epsilon(nrmagg)) then
|
||||
if (idx <= nr) then
|
||||
if (ilaggr(idx) == -1) then
|
||||
if (ilaggr(idx) == ilaggr_neginit) then
|
||||
! Now, if both vertices are local, the aggregate is local
|
||||
! (kinda obvious).
|
||||
nlaggr(iam) = nlaggr(iam) + 1
|
||||
@@ -275,6 +289,9 @@ contains
|
||||
ilaggr(idx) = nlaggr(iam)
|
||||
wtemp(k) = w(k)/nrmagg
|
||||
wtemp(idx) = w(idx)/nrmagg
|
||||
else
|
||||
write(0,*) iam,' Inconsistent mate? ',k,mate(k),idx,&
|
||||
&mate(idx),ilaggr(idx)
|
||||
end if
|
||||
nlpairs = nlpairs+1
|
||||
else if (idx <= nc) then
|
||||
@@ -294,7 +311,7 @@ contains
|
||||
ilaggr(k) = nlaggr(iam)
|
||||
nlpairs = nlpairs+1
|
||||
else
|
||||
ilaggr(k) = -2
|
||||
ilaggr(k) = ilaggr_nonlocal
|
||||
end if
|
||||
else
|
||||
! Use a statistically unbiased tie-breaking rule,
|
||||
@@ -309,7 +326,7 @@ contains
|
||||
ilaggr(k) = nlaggr(iam)
|
||||
nlpairs = nlpairs+1
|
||||
else
|
||||
ilaggr(k) = -2
|
||||
ilaggr(k) = ilaggr_nonlocal
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
@@ -325,6 +342,12 @@ contains
|
||||
nlsingl = nlsingl + 1
|
||||
end if
|
||||
end if
|
||||
if (ilaggr(k) == ilaggr_neginit) then
|
||||
write(0,*) iam,' Error: no update to ',k,mate(k),&
|
||||
& abs(w(k)),nrmagg,epsilon(nrmagg),wtemp(k)
|
||||
end if
|
||||
else
|
||||
if (ilaggr(k)<0) write(0,*) 'Strange? ',k,ilaggr(k)
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
@@ -332,7 +355,7 @@ contains
|
||||
if (do_timings) call psb_tic(idx_phase3)
|
||||
|
||||
! Ok, now compute offsets, gather halo and fix non-local
|
||||
! aggregates (those where ilaggr == -2)
|
||||
! aggregates (those where ilaggr == ilaggr_nonlocal)
|
||||
call psb_sum(ictxt,nlaggr)
|
||||
ntaggr = sum(nlaggr(0:np-1))
|
||||
naggrm1 = sum(nlaggr(0:iam-1))
|
||||
@@ -347,7 +370,7 @@ contains
|
||||
call psb_halo(wtemp,desc_a,info)
|
||||
! Cleanup as yet unmarked entries
|
||||
do k=1,nr
|
||||
if (ilaggr(k) == -2) then
|
||||
if (ilaggr(k) == ilaggr_nonlocal) then
|
||||
idx = mate(k)
|
||||
if (idx > nr) then
|
||||
i = ilaggr(idx)
|
||||
@@ -359,9 +382,14 @@ contains
|
||||
else
|
||||
write(0,*) 'Error : unresolved (paired) index ',k,idx,i,nr,nc, ilv(k),ilv(idx)
|
||||
end if
|
||||
end if
|
||||
if (ilaggr(k) <0) then
|
||||
write(0,*) 'Matchboxp: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
|
||||
else if (ilaggr(k) <0) then
|
||||
write(0,*) iam,'Matchboxp: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
|
||||
write(0,*) iam,' : : ',nr,nc,mate(k)
|
||||
if (mate(k) <= nr) then
|
||||
write(0,*) iam,' : : ',ilaggr(mate(k)),mate(mate(k)),&
|
||||
& ilv(k),ilv(mate(k)), ilv(mate(mate(k))),ilaggr(mate(mate(k)))
|
||||
end if
|
||||
flush(0)
|
||||
end if
|
||||
end do
|
||||
if (debug_sync) then
|
||||
@@ -414,7 +442,7 @@ contains
|
||||
|
||||
end block
|
||||
if (iam == 0) then
|
||||
write(0,*) 'Matching statistics: Unmatched nodes ',&
|
||||
write(0,*) iam,'Matching statistics: Unmatched nodes ',&
|
||||
& nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
|
||||
end if
|
||||
|
||||
|
||||
@@ -78,7 +78,8 @@ module amg_d_mumps_solver
|
||||
!
|
||||
! Controls to be set before MUMPS instantiation:
|
||||
!
|
||||
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: LOCAL 1==amg_global_solver_: GLOBAL
|
||||
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: 'LOCAL_SOLVER
|
||||
! 1==amg_global_solver_: 'GLOBAL_SOLVER'
|
||||
! IPAR(2) : MUMPS_PRINT_ERR print verbosity (see MUMPS)
|
||||
! IPAR(3) : MUMPS_SYM 0: non-symmetric 2: symmetric
|
||||
integer(psb_ipk_), dimension(3) :: ipar
|
||||
|
||||
@@ -188,6 +188,7 @@ module amg_d_onelev_mod
|
||||
procedure, pass(lv) :: clone => d_base_onelev_clone
|
||||
procedure, pass(lv) :: cnv => amg_d_base_onelev_cnv
|
||||
procedure, pass(lv) :: descr => amg_d_base_onelev_descr
|
||||
procedure, pass(lv) :: memory_use => amg_d_base_onelev_memory_use
|
||||
procedure, pass(lv) :: default => d_base_onelev_default
|
||||
procedure, pass(lv) :: free => amg_d_base_onelev_free
|
||||
procedure, pass(lv) :: free_smoothers => amg_d_base_onelev_free_smoothers
|
||||
@@ -274,6 +275,23 @@ module amg_d_onelev_mod
|
||||
end subroutine amg_d_base_onelev_descr
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dlinmap_type, psb_dpk_, amg_d_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_d_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine amg_d_base_onelev_memory_use
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
import :: amg_d_onelev_type, psb_d_base_vect_type, psb_dpk_, &
|
||||
|
||||
@@ -0,0 +1,548 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_d_poly_smoother_mod.f90
|
||||
!
|
||||
! Module: amg_d_poly_smoother_mod
|
||||
!
|
||||
! This module defines:
|
||||
! the amg_d_poly_smoother_type data structure containing the
|
||||
! smoother for a Jacobi/block Jacobi smoother.
|
||||
! The smoother stores in ND the block off-diagonal matrix.
|
||||
! One special case is treated separately, when the solver is DIAG or L1-DIAG
|
||||
! then the ND is the entire off-diagonal part of the matrix (including the
|
||||
! main diagonal block), so that it becomes possible to implement
|
||||
! a pure Jacobi or L1-Jacobi global solver.
|
||||
!
|
||||
module amg_d_poly_coeff_mod
|
||||
use psb_base_mod
|
||||
|
||||
real(psb_dpk_), parameter :: amg_d_poly_a_vect(30) = [ &
|
||||
& 0.3333333333333333_psb_dpk_, &
|
||||
& 0.1805359927403007_psb_dpk_, &
|
||||
& 0.1159278464862213_psb_dpk_, &
|
||||
& 0.0820780659590383_psb_dpk_, &
|
||||
& 0.0618496002413377_psb_dpk_, &
|
||||
& 0.0486605823426062_psb_dpk_, &
|
||||
& 0.0395132986024057_psb_dpk_, &
|
||||
& 0.0328701017544880_psb_dpk_, &
|
||||
& 0.0278702862721800_psb_dpk_, &
|
||||
& 0.0239987409600620_psb_dpk_, &
|
||||
& 0.0209304400432259_psb_dpk_, &
|
||||
& 0.0184513099045066_psb_dpk_, &
|
||||
& 0.0164152586042591_psb_dpk_, &
|
||||
& 0.0147195638076874_psb_dpk_, &
|
||||
& 0.0132901324757843_psb_dpk_, &
|
||||
& 0.0120723317737698_psb_dpk_, &
|
||||
& 0.0110250964606384_psb_dpk_, &
|
||||
& 0.0101170330064859_psb_dpk_, &
|
||||
& 0.0093237789039835_psb_dpk_, &
|
||||
& 0.0086261728849515_psb_dpk_, &
|
||||
& 0.0080089618703679_psb_dpk_, &
|
||||
& 0.0074598709610601_psb_dpk_, &
|
||||
& 0.0069689238144320_psb_dpk_, &
|
||||
& 0.0065279387776372_psb_dpk_, &
|
||||
& 0.0061301503808627_psb_dpk_, &
|
||||
& 0.0057699215598864_psb_dpk_, &
|
||||
& 0.0054425224281914_psb_dpk_, &
|
||||
& 0.0051439584672521_psb_dpk_, &
|
||||
& 0.0048708358327268_psb_dpk_, &
|
||||
& 0.0046202548314912_psb_dpk_ ];
|
||||
|
||||
real(psb_dpk_), parameter :: amg_d_poly_beta_vect(900) = [ &
|
||||
& 1.1250000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0238728757031315_psb_dpk_, 1.2640890537108553_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0084254478202830_psb_dpk_, 1.0886783920873087_psb_dpk_, &
|
||||
& 1.3375312590961856_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0039131042728535_psb_dpk_, 1.0403581118859304_psb_dpk_, &
|
||||
& 1.1486349854625493_psb_dpk_, 1.3826886924100055_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0021293014616472_psb_dpk_, 1.0217371154926094_psb_dpk_, &
|
||||
& 1.0787243319260302_psb_dpk_, 1.1981006529266300_psb_dpk_, &
|
||||
& 1.4132254279168215_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0012851725594023_psb_dpk_, 1.0130429303523338_psb_dpk_, &
|
||||
& 1.0467821512411335_psb_dpk_, 1.1161648941967548_psb_dpk_, &
|
||||
& 1.2382902021844453_psb_dpk_, 1.4352429710674484_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0008346439791242_psb_dpk_, 1.0084394943012289_psb_dpk_, &
|
||||
& 1.0300870776871385_psb_dpk_, 1.0740838409200377_psb_dpk_, &
|
||||
& 1.1503618670736642_psb_dpk_, 1.2711647404613990_psb_dpk_, &
|
||||
& 1.4518665864936395_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0005724663119766_psb_dpk_, 1.0057742766241562_psb_dpk_, &
|
||||
& 1.0205018792294143_psb_dpk_, 1.0501980344456543_psb_dpk_, &
|
||||
& 1.1011557298494106_psb_dpk_, 1.1808604280685657_psb_dpk_, &
|
||||
& 1.2983858538257604_psb_dpk_, 1.4648607315109978_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0004096007283281_psb_dpk_, 1.0041243950610661_psb_dpk_, &
|
||||
& 1.0146021214826659_psb_dpk_, 1.0356111362667175_psb_dpk_, &
|
||||
& 1.0713997252919425_psb_dpk_, 1.1268827371096291_psb_dpk_, &
|
||||
& 1.2078521914072933_psb_dpk_, 1.3212193071674674_psb_dpk_, &
|
||||
& 1.4752964282069962_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0003031222965291_psb_dpk_, 1.0030484066079688_psb_dpk_, &
|
||||
& 1.0107702271538761_psb_dpk_, 1.0261901159764004_psb_dpk_, &
|
||||
& 1.0523172493375519_psb_dpk_, 1.0925574320754976_psb_dpk_, &
|
||||
& 1.1508337666397197_psb_dpk_, 1.2317225087089441_psb_dpk_, &
|
||||
& 1.3406080202445980_psb_dpk_, 1.4838612440701109_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0002305859520939_psb_dpk_, 1.0023167502402850_psb_dpk_, &
|
||||
& 1.0081724539630488_psb_dpk_, 1.0198298656634219_psb_dpk_, &
|
||||
& 1.0395021023532465_psb_dpk_, 1.0696504270054137_psb_dpk_, &
|
||||
& 1.1130575429574259_psb_dpk_, 1.1729087627556418_psb_dpk_, &
|
||||
& 1.2528830057679230_psb_dpk_, 1.3572557991951903_psb_dpk_, &
|
||||
& 1.4910167256413891_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0001794720082837_psb_dpk_, 1.0018018913961957_psb_dpk_, &
|
||||
& 1.0063486190730762_psb_dpk_, 1.0153786456630600_psb_dpk_, &
|
||||
& 1.0305694283076039_psb_dpk_, 1.0537601969394355_psb_dpk_, &
|
||||
& 1.0869986259207296_psb_dpk_, 1.1325918309791341_psb_dpk_, &
|
||||
& 1.1931627335817252_psb_dpk_, 1.2717129367511055_psb_dpk_, &
|
||||
& 1.3716933796979953_psb_dpk_, 1.4970841857556243_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0001424192155957_psb_dpk_, 1.0014290693262966_psb_dpk_, &
|
||||
& 1.0050302898629815_psb_dpk_, 1.0121691051849540_psb_dpk_, &
|
||||
& 1.0241487434279255_psb_dpk_, 1.0423815888082042_psb_dpk_, &
|
||||
& 1.0684200812870084_psb_dpk_, 1.1039901093675994_psb_dpk_, &
|
||||
& 1.1510274824264566_psb_dpk_, 1.2117181191012512_psb_dpk_, &
|
||||
& 1.2885426486512805_psb_dpk_, 1.3843261938099158_psb_dpk_, &
|
||||
& 1.5022941875736890_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0001149053826193_psb_dpk_, 1.0011524637691460_psb_dpk_, &
|
||||
& 1.0040535733326481_psb_dpk_, 1.0097959057315313_psb_dpk_, &
|
||||
& 1.0194130047299461_psb_dpk_, 1.0340142503543679_psb_dpk_, &
|
||||
& 1.0548059960662932_psb_dpk_, 1.0831142030181304_psb_dpk_, &
|
||||
& 1.1204089166089239_psb_dpk_, 1.1683309565544606_psb_dpk_, &
|
||||
& 1.2287212228823874_psb_dpk_, 1.3036530570781755_psb_dpk_, &
|
||||
& 1.3954681405367855_psb_dpk_, 1.5068164620958386_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000940475075257_psb_dpk_, 1.0009429169634352_psb_dpk_, &
|
||||
& 1.0033144905644482_psb_dpk_, 1.0080029483381612_psb_dpk_, &
|
||||
& 1.0158423625914039_psb_dpk_, 1.0277208331770495_psb_dpk_, &
|
||||
& 1.0445953542283146_psb_dpk_, 1.0675076120612534_psb_dpk_, &
|
||||
& 1.0976009254588965_psb_dpk_, 1.1361385536615733_psb_dpk_, &
|
||||
& 1.1845236142623621_psb_dpk_, 1.2443208730447588_psb_dpk_, &
|
||||
& 1.3172806908339272_psb_dpk_, 1.4053654389356023_psb_dpk_, &
|
||||
& 1.5107787250184523_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000779482817921_psb_dpk_, 1.0007812684725339_psb_dpk_, &
|
||||
& 1.0027448797440124_psb_dpk_, 1.0066229101701514_psb_dpk_, &
|
||||
& 1.0130985883697137_psb_dpk_, 1.0228944832933697_psb_dpk_, &
|
||||
& 1.0367832140998394_psb_dpk_, 1.0555987571989653_psb_dpk_, &
|
||||
& 1.0802484840556024_psb_dpk_, 1.1117260713149764_psb_dpk_, &
|
||||
& 1.1511254343107276_psb_dpk_, 1.1996558461497355_psb_dpk_, &
|
||||
& 1.2586584174494597_psb_dpk_, 1.3296241265666493_psb_dpk_, &
|
||||
& 1.4142136069557629_psb_dpk_, 1.5142789173034623_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000653242183546_psb_dpk_, 1.0006545722939437_psb_dpk_, &
|
||||
& 1.0022987777448662_psb_dpk_, 1.0055432691173583_psb_dpk_, &
|
||||
& 1.0109550075016893_psb_dpk_, 1.0191301541168694_psb_dpk_, &
|
||||
& 1.0307019481191382_psb_dpk_, 1.0463489778000818_psb_dpk_, &
|
||||
& 1.0668039321569163_psb_dpk_, 1.0928629244731740_psb_dpk_, &
|
||||
& 1.1253954850882542_psb_dpk_, 1.1653553270075827_psb_dpk_, &
|
||||
& 1.2137919954743157_psb_dpk_, 1.2718635211544003_psb_dpk_, &
|
||||
& 1.3408502062615073_psb_dpk_, 1.4221696838526183_psb_dpk_, &
|
||||
& 1.5173934027630227_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000552858792859_psb_dpk_, 1.0005538659610900_psb_dpk_, &
|
||||
& 1.0019444166743086_psb_dpk_, 1.0046864301776393_psb_dpk_, &
|
||||
& 1.0092557508630260_psb_dpk_, 1.0161502674772371_psb_dpk_, &
|
||||
& 1.0258958148322650_psb_dpk_, 1.0390523408953256_psb_dpk_, &
|
||||
& 1.0562203973533295_psb_dpk_, 1.0780480145522537_psb_dpk_, &
|
||||
& 1.1052380250439366_psb_dpk_, 1.1385559038570177_psb_dpk_, &
|
||||
& 1.1788381980793483_psb_dpk_, 1.2270016234308427_psb_dpk_, &
|
||||
& 1.2840529112630572_psb_dpk_, 1.3510994958895055_psb_dpk_, &
|
||||
& 1.4293611393851839_psb_dpk_, 1.5201825990516680_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000472036358790_psb_dpk_, 1.0004728102642675_psb_dpk_, &
|
||||
& 1.0016593577469159_psb_dpk_, 1.0039976891368516_psb_dpk_, &
|
||||
& 1.0078911941833455_psb_dpk_, 1.0137601583069535_psb_dpk_, &
|
||||
& 1.0220462561721002_psb_dpk_, 1.0332172281153209_psb_dpk_, &
|
||||
& 1.0477717791157513_psb_dpk_, 1.0662447417325256_psb_dpk_, &
|
||||
& 1.0892125464929936_psb_dpk_, 1.1172990456131733_psb_dpk_, &
|
||||
& 1.1511817386833911_psb_dpk_, 1.1915984520803475_psb_dpk_, &
|
||||
& 1.2393545273929878_psb_dpk_, 1.2953305781018039_psb_dpk_, &
|
||||
& 1.3604908781568688_psb_dpk_, 1.4358924509939206_psb_dpk_, &
|
||||
& 1.5226949329440265_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000406232569254_psb_dpk_, 1.0004068351374691_psb_dpk_, &
|
||||
& 1.0014274431564170_psb_dpk_, 1.0034377175807407_psb_dpk_, &
|
||||
& 1.0067826854070978_psb_dpk_, 1.0118204999571436_psb_dpk_, &
|
||||
& 1.0189259121271075_psb_dpk_, 1.0284938700470616_psb_dpk_, &
|
||||
& 1.0409432748132981_psb_dpk_, 1.0567209210598594_psb_dpk_, &
|
||||
& 1.0763056524407055_psb_dpk_, 1.1002127636100871_psb_dpk_, &
|
||||
& 1.1289986820268283_psb_dpk_, 1.1632659648787138_psb_dpk_, &
|
||||
& 1.2036686486408621_psb_dpk_, 1.2509179912601627_psb_dpk_, &
|
||||
& 1.3057886497146727_psb_dpk_, 1.3691253387497200_psb_dpk_, &
|
||||
& 1.4418500199624611_psb_dpk_, 1.5249696741164267_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000352114440929_psb_dpk_, 1.0003525892395289_psb_dpk_, &
|
||||
& 1.0012368357172980_psb_dpk_, 1.0029777430511673_psb_dpk_, &
|
||||
& 1.0058727830027672_psb_dpk_, 1.0102297507781717_psb_dpk_, &
|
||||
& 1.0163694815733537_psb_dpk_, 1.0246286588536329_psb_dpk_, &
|
||||
& 1.0353627340015590_psb_dpk_, 1.0489489776835172_psb_dpk_, &
|
||||
& 1.0657896841306789_psb_dpk_, 1.0863155505114006_psb_dpk_, &
|
||||
& 1.1109892546943501_psb_dpk_, 1.1403092559728156_psb_dpk_, &
|
||||
& 1.1748138447471401_psb_dpk_, 1.2150854687543668_psb_dpk_, &
|
||||
& 1.2617553651999671_psb_dpk_, 1.3155085300984379_psb_dpk_, &
|
||||
& 1.3770890582780710_psb_dpk_, 1.4473058898645985_psb_dpk_, &
|
||||
& 1.5270390016420912_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000307198714835_psb_dpk_, 1.0003075769178242_psb_dpk_, &
|
||||
& 1.0010787281022711_psb_dpk_, 1.0025963829693492_psb_dpk_, &
|
||||
& 1.0051188625231162_psb_dpk_, 1.0089126974249720_psb_dpk_, &
|
||||
& 1.0142547789760521_psb_dpk_, 1.0214345766593154_psb_dpk_, &
|
||||
& 1.0307564364069204_psb_dpk_, 1.0425419742322541_psb_dpk_, &
|
||||
& 1.0571325804249445_psb_dpk_, 1.0748920501551993_psb_dpk_, &
|
||||
& 1.0962093570737961_psb_dpk_, 1.1215015873309027_psb_dpk_, &
|
||||
& 1.1512170523743910_psb_dpk_, 1.1858385999327761_psb_dpk_, &
|
||||
& 1.2258871437439198_psb_dpk_, 1.2719254338660289_psb_dpk_, &
|
||||
& 1.3245620908078453_psb_dpk_, 1.3844559282498121_psb_dpk_, &
|
||||
& 1.4523205908039656_psb_dpk_, 1.5289295350887884_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000269609460124_psb_dpk_, 1.0002699137181752_psb_dpk_, &
|
||||
& 1.0009464748475532_psb_dpk_, 1.0022775198638552_psb_dpk_, &
|
||||
& 1.0044888368184179_psb_dpk_, 1.0078128087804721_psb_dpk_, &
|
||||
& 1.0124901352066715_psb_dpk_, 1.0187716022931539_psb_dpk_, &
|
||||
& 1.0269199126829005_psb_dpk_, 1.0372115852204526_psb_dpk_, &
|
||||
& 1.0499389358225151_psb_dpk_, 1.0654121509688057_psb_dpk_, &
|
||||
& 1.0839614658147161_psb_dpk_, 1.1059394594887115_psb_dpk_, &
|
||||
& 1.1317234807654135_psb_dpk_, 1.1617182180038959_psb_dpk_, &
|
||||
& 1.1963584280123116_psb_dpk_, 1.2361118393501820_psb_dpk_, &
|
||||
& 1.2814822465106404_psb_dpk_, 1.3330128124440397_psb_dpk_, &
|
||||
& 1.3912895979940381_psb_dpk_, 1.4569453380258381_psb_dpk_, &
|
||||
& 1.5306634853375161_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000237911597230_psb_dpk_, 1.0002381585998457_psb_dpk_, &
|
||||
& 1.0008349974382460_psb_dpk_, 1.0020088476285827_psb_dpk_, &
|
||||
& 1.0039582343156432_psb_dpk_, 1.0068870298152559_psb_dpk_, &
|
||||
& 1.0110058445931565_psb_dpk_, 1.0165334547611182_psb_dpk_, &
|
||||
& 1.0236982737890488_psb_dpk_, 1.0327398763510158_psb_dpk_, &
|
||||
& 1.0439105824804926_psb_dpk_, 1.0574771105088172_psb_dpk_, &
|
||||
& 1.0737223076000839_psb_dpk_, 1.0929469670793606_psb_dpk_, &
|
||||
& 1.1154717421787756_psb_dpk_, 1.1416391663018148_psb_dpk_, &
|
||||
& 1.1718157904303341_psb_dpk_, 1.2063944488757254_psb_dpk_, &
|
||||
& 1.2457966652063013_psb_dpk_, 1.2904752108716941_psb_dpk_, &
|
||||
& 1.3409168297942540_psb_dpk_, 1.3976451430108305_psb_dpk_, &
|
||||
& 1.4612237483301715_psb_dpk_, 1.5322595309246121_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000210994601235_psb_dpk_, 1.0002111968041199_psb_dpk_, &
|
||||
& 1.0007403694573151_psb_dpk_, 1.0017808593384865_psb_dpk_, &
|
||||
& 1.0035081686576977_psb_dpk_, 1.0061021720448531_psb_dpk_, &
|
||||
& 1.0097482505685551_psb_dpk_, 1.0146384533048582_psb_dpk_, &
|
||||
& 1.0209726922414943_psb_dpk_, 1.0289599764553270_psb_dpk_, &
|
||||
& 1.0388196916802268_psb_dpk_, 1.0507829315895938_psb_dpk_, &
|
||||
& 1.0650938873538003_psb_dpk_, 1.0820113022982043_psb_dpk_, &
|
||||
& 1.1018099987843295_psb_dpk_, 1.1247824847650900_psb_dpk_, &
|
||||
& 1.1512406478277994_psb_dpk_, 1.1815175449359154_psb_dpk_, &
|
||||
& 1.2159692965153148_psb_dpk_, 1.2549770940040335_psb_dpk_, &
|
||||
& 1.2989493304988182_psb_dpk_, 1.3483238646890843_psb_dpk_, &
|
||||
& 1.4035704288718982_psb_dpk_, 1.4651931924923849_psb_dpk_, &
|
||||
& 1.5337334933563860_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000187989989242_psb_dpk_, 1.0001881567984481_psb_dpk_, &
|
||||
& 1.0006595227084085_psb_dpk_, 1.0015861311895899_psb_dpk_, &
|
||||
& 1.0031239047778964_psb_dpk_, 1.0054323694760092_psb_dpk_, &
|
||||
& 1.0086755868504005_psb_dpk_, 1.0130231071421940_psb_dpk_, &
|
||||
& 1.0186509477893992_psb_dpk_, 1.0257426018654052_psb_dpk_, &
|
||||
& 1.0344900810652515_psb_dpk_, 1.0450949980170887_psb_dpk_, &
|
||||
& 1.0577696928624343_psb_dpk_, 1.0727384092356933_psb_dpk_, &
|
||||
& 1.0902385249817814_psb_dpk_, 1.1105218431816117_psb_dpk_, &
|
||||
& 1.1338559493090710_psb_dpk_, 1.1605256406217599_psb_dpk_, &
|
||||
& 1.1908344341913664_psb_dpk_, 1.2251061603103259_psb_dpk_, &
|
||||
& 1.2636866483695495_psb_dpk_, 1.3069455126904677_psb_dpk_, &
|
||||
& 1.3552780462128098_psb_dpk_, 1.4091072303921326_psb_dpk_, &
|
||||
& 1.4688858701459975_psb_dpk_, 1.5350988632115488_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000168211938973_psb_dpk_, 1.0001683505351420_psb_dpk_, &
|
||||
& 1.0005900360142315_psb_dpk_, 1.0014188084960041_psb_dpk_, &
|
||||
& 1.0027938311393803_psb_dpk_, 1.0048572584314193_psb_dpk_, &
|
||||
& 1.0077550080990554_psb_dpk_, 1.0116375492127350_psb_dpk_, &
|
||||
& 1.0166607098595459_psb_dpk_, 1.0229865078405374_psb_dpk_, &
|
||||
& 1.0307840079371537_psb_dpk_, 1.0402302093961155_psb_dpk_, &
|
||||
& 1.0515109674005423_psb_dpk_, 1.0648219524284319_psb_dpk_, &
|
||||
& 1.0803696515480321_psb_dpk_, 1.0983724158638981_psb_dpk_, &
|
||||
& 1.1190615585080472_psb_dpk_, 1.1426825077681895_psb_dpk_, &
|
||||
& 1.1694960201606786_psb_dpk_, 1.1997794584895700_psb_dpk_, &
|
||||
& 1.2338281401870808_psb_dpk_, 1.2719567615042522_psb_dpk_, &
|
||||
& 1.3145009034164739_psb_dpk_, 1.3618186254259919_psb_dpk_, &
|
||||
& 1.4142921537855777_psb_dpk_, 1.4723296710339275_psb_dpk_, &
|
||||
& 1.5363672141264497_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000151113991291_psb_dpk_, 1.0001512299115287_psb_dpk_, &
|
||||
& 1.0005299814085029_psb_dpk_, 1.0012742317597600_psb_dpk_, &
|
||||
& 1.0025087130476142_psb_dpk_, 1.0043606572645858_psb_dpk_, &
|
||||
& 1.0069604400315522_psb_dpk_, 1.0104422369100252_psb_dpk_, &
|
||||
& 1.0149446949285030_psb_dpk_, 1.0206116219981500_psb_dpk_, &
|
||||
& 1.0275926969588451_psb_dpk_, 1.0360442030716124_psb_dpk_, &
|
||||
& 1.0461297878595799_psb_dpk_, 1.0580212522952626_psb_dpk_, &
|
||||
& 1.0718993724396861_psb_dpk_, 1.0879547567564958_psb_dpk_, &
|
||||
& 1.1063887424550545_psb_dpk_, 1.1274143343577541_psb_dpk_, &
|
||||
& 1.1512571899424711_psb_dpk_, 1.1781566543781672_psb_dpk_, &
|
||||
& 1.2083668495540898_psb_dpk_, 1.2421578212983135_psb_dpk_, &
|
||||
& 1.2798167491932815_psb_dpk_, 1.3216492236219661_psb_dpk_, &
|
||||
& 1.3679805949228399_psb_dpk_, 1.4191573997915068_psb_dpk_, &
|
||||
& 1.4755488703473389_psb_dpk_, 1.5375485315807513_psb_dpk_, &
|
||||
& 0.0000000000000000_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000136257096588_psb_dpk_, 1.0001363546506836_psb_dpk_, &
|
||||
& 1.0004778107488095_psb_dpk_, 1.0011486612681773_psb_dpk_, &
|
||||
& 1.0022611433613271_psb_dpk_, 1.0039295964948667_psb_dpk_, &
|
||||
& 1.0062710027404669_psb_dpk_, 1.0094055369479136_psb_dpk_, &
|
||||
& 1.0134571288503909_psb_dpk_, 1.0185540391932908_psb_dpk_, &
|
||||
& 1.0248294520252528_psb_dpk_, 1.0324220853457433_psb_dpk_, &
|
||||
& 1.0414768223656390_psb_dpk_, 1.0521453657079123_psb_dpk_, &
|
||||
& 1.0645869169533493_psb_dpk_, 1.0789688840227822_psb_dpk_, &
|
||||
& 1.0954676189818162_psb_dpk_, 1.1142691889576817_psb_dpk_, &
|
||||
& 1.1355701829701565_psb_dpk_, 1.1595785576006521_psb_dpk_, &
|
||||
& 1.1865145245551894_psb_dpk_, 1.2166114833191515_psb_dpk_, &
|
||||
& 1.2501170022543431_psb_dpk_, 1.2872938516530203_psb_dpk_, &
|
||||
& 1.3284210924391027_psb_dpk_, 1.3737952243949607_psb_dpk_, &
|
||||
& 1.4237313979931023_psb_dpk_, 1.4785646941265451_psb_dpk_, &
|
||||
& 1.5386514762605854_psb_dpk_, 0.0000000000000000_psb_dpk_, &
|
||||
& 1.0000123285767939_psb_dpk_, 1.0001233683396147_psb_dpk_, &
|
||||
& 1.0004322711781202_psb_dpk_, 1.0010390719329101_psb_dpk_, &
|
||||
& 1.0020451337350940_psb_dpk_, 1.0035535979966428_psb_dpk_, &
|
||||
& 1.0056698406248343_psb_dpk_, 1.0085019360540697_psb_dpk_, &
|
||||
& 1.0121611307132341_psb_dpk_, 1.0167623275769953_psb_dpk_, &
|
||||
& 1.0224245834847208_psb_dpk_, 1.0292716209515502_psb_dpk_, &
|
||||
& 1.0374323562422998_psb_dpk_, 1.0470414455308106_psb_dpk_, &
|
||||
& 1.0582398510249318_psb_dpk_, 1.0711754290010183_psb_dpk_, &
|
||||
& 1.0860035417614331_psb_dpk_, 1.1028876956049132_psb_dpk_, &
|
||||
& 1.1220002069820316_psb_dpk_, 1.1435228990979547_psb_dpk_, &
|
||||
& 1.1676478313209715_psb_dpk_, 1.1945780638597872_psb_dpk_, &
|
||||
& 1.2245284602839432_psb_dpk_, 1.2577265305821996_psb_dpk_, &
|
||||
& 1.2944133175813315_psb_dpk_, 1.3348443296857557_psb_dpk_, &
|
||||
& 1.3792905230439911_psb_dpk_, 1.4280393364047606_psb_dpk_, &
|
||||
& 1.4813957820911738_psb_dpk_, 1.5396835966986973_psb_dpk_ ]
|
||||
|
||||
|
||||
|
||||
|
||||
!!$ [1.1250000000000000_psb_dpk_, 0.0_psb_dpk_, 0.0_psb_dpk__psb_dpk_,,&
|
||||
!!$ & 1.0238728757031315_psb_dpk_, 1.2640890537108553_psb_dpk_, 0.0_psb_dpk_,&
|
||||
!!$ & 1.0084254478202830_psb_dpk_, 1.0886783920873087_psb_dpk_, 1.3375312590961856_psb_dpk_]
|
||||
|
||||
real(psb_dpk_), parameter :: amg_d_poly_beta_mat(30,30)=reshape(amg_d_poly_beta_vect,[30,30])
|
||||
|
||||
end module amg_d_poly_coeff_mod
|
||||
@@ -0,0 +1,374 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_d_poly_smoother_mod.f90
|
||||
!
|
||||
! Module: amg_d_poly_smoother_mod
|
||||
!
|
||||
! This module defines:
|
||||
! the amg_d_poly_smoother_type data structure containing the
|
||||
! smoother for a Jacobi/block Jacobi smoother.
|
||||
! The smoother stores in ND the block off-diagonal matrix.
|
||||
! One special case is treated separately, when the solver is DIAG or L1-DIAG
|
||||
! then the ND is the entire off-diagonal part of the matrix (including the
|
||||
! main diagonal block), so that it becomes possible to implement
|
||||
! a pure Jacobi or L1-Jacobi global solver.
|
||||
!
|
||||
module amg_d_poly_smoother
|
||||
use amg_d_base_smoother_mod
|
||||
use amg_d_poly_coeff_mod
|
||||
|
||||
type, extends(amg_d_base_smoother_type) :: amg_d_poly_smoother_type
|
||||
! The local solver component is inherited from the
|
||||
! parent type.
|
||||
! class(amg_d_base_solver_type), allocatable :: sv
|
||||
!
|
||||
integer(psb_ipk_) :: pdegree, variant
|
||||
integer(psb_ipk_) :: rho_estimate=amg_poly_rho_est_power_
|
||||
integer(psb_ipk_) :: rho_estimate_iterations=10
|
||||
type(psb_dspmat_type), pointer :: pa => null()
|
||||
real(psb_dpk_), allocatable :: poly_beta(:)
|
||||
real(psb_dpk_) :: cf_a = dzero
|
||||
real(psb_dpk_) :: rho_ba = -done
|
||||
contains
|
||||
procedure, pass(sm) :: apply_v => amg_d_poly_smoother_apply_vect
|
||||
!!$ procedure, pass(sm) :: apply_a => amg_d_poly_smoother_apply
|
||||
procedure, pass(sm) :: dump => amg_d_poly_smoother_dmp
|
||||
procedure, pass(sm) :: build => amg_d_poly_smoother_bld
|
||||
procedure, pass(sm) :: cnv => amg_d_poly_smoother_cnv
|
||||
procedure, pass(sm) :: clone => amg_d_poly_smoother_clone
|
||||
procedure, pass(sm) :: clone_settings => amg_d_poly_smoother_clone_settings
|
||||
procedure, pass(sm) :: clear_data => amg_d_poly_smoother_clear_data
|
||||
procedure, pass(sm) :: free => d_poly_smoother_free
|
||||
procedure, pass(sm) :: cseti => amg_d_poly_smoother_cseti
|
||||
procedure, pass(sm) :: csetc => amg_d_poly_smoother_csetc
|
||||
procedure, pass(sm) :: csetr => amg_d_poly_smoother_csetr
|
||||
procedure, pass(sm) :: descr => amg_d_poly_smoother_descr
|
||||
procedure, pass(sm) :: sizeof => d_poly_smoother_sizeof
|
||||
procedure, pass(sm) :: default => d_poly_smoother_default
|
||||
procedure, pass(sm) :: get_nzeros => d_poly_smoother_get_nzeros
|
||||
procedure, pass(sm) :: get_wrksz => d_poly_smoother_get_wrksize
|
||||
procedure, nopass :: get_fmt => d_poly_smoother_get_fmt
|
||||
procedure, nopass :: get_id => d_poly_smoother_get_id
|
||||
end type amg_d_poly_smoother_type
|
||||
private :: d_poly_smoother_free, &
|
||||
& d_poly_smoother_sizeof, d_poly_smoother_get_nzeros, &
|
||||
& d_poly_smoother_get_fmt, d_poly_smoother_get_id, &
|
||||
& d_poly_smoother_get_wrksize
|
||||
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
& sweeps,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
|
||||
& psb_ipk_
|
||||
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
type(psb_d_vect_type),intent(inout) :: x
|
||||
type(psb_d_vect_type),intent(inout) :: y
|
||||
real(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
type(psb_d_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_d_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_d_poly_smoother_apply_vect
|
||||
end interface
|
||||
|
||||
!!$ interface
|
||||
!!$ subroutine amg_d_poly_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
!!$ & sweeps,work,info,init,initu)
|
||||
!!$ import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
|
||||
!!$ & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, &
|
||||
!!$ & psb_ipk_
|
||||
!!$ type(psb_desc_type), intent(in) :: desc_data
|
||||
!!$ class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
!!$ real(psb_dpk_),intent(inout) :: x(:)
|
||||
!!$ real(psb_dpk_),intent(inout) :: y(:)
|
||||
!!$ real(psb_dpk_),intent(in) :: alpha,beta
|
||||
!!$ character(len=1),intent(in) :: trans
|
||||
!!$ integer(psb_ipk_), intent(in) :: sweeps
|
||||
!!$ real(psb_dpk_),target, intent(inout) :: work(:)
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ character, intent(in), optional :: init
|
||||
!!$ real(psb_dpk_),intent(inout), optional :: initu(:)
|
||||
!!$ end subroutine amg_d_poly_smoother_apply
|
||||
!!$ end interface
|
||||
!!$
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_d_poly_smoother_type, psb_d_vect_type, psb_dpk_, &
|
||||
& psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
type(psb_dspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_d_poly_smoother_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_cnv(sm,info,amold,vmold,imold)
|
||||
import :: amg_d_poly_smoother_type, psb_dpk_, &
|
||||
& psb_d_base_sparse_mat, psb_d_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_d_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_d_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_d_poly_smoother_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, &
|
||||
& psb_ipk_
|
||||
implicit none
|
||||
class(amg_d_poly_smoother_type), intent(in) :: sm
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
end subroutine amg_d_poly_smoother_dmp
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_clone(sm,smout,info)
|
||||
import :: amg_d_poly_smoother_type, psb_dpk_, &
|
||||
& amg_d_base_smoother_type, psb_ipk_
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_poly_smoother_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_clone_settings(sm,smout,info)
|
||||
import :: amg_d_poly_smoother_type, psb_dpk_, &
|
||||
& amg_d_base_smoother_type, psb_ipk_
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
class(amg_d_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_poly_smoother_clone_settings
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_clear_data(sm,info)
|
||||
import :: amg_d_poly_smoother_type, psb_dpk_, &
|
||||
& amg_d_base_smoother_type, psb_ipk_
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_d_poly_smoother_clear_data
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_descr(sm,info,iout,coarse,prefix)
|
||||
import :: amg_d_poly_smoother_type, psb_ipk_
|
||||
class(amg_d_poly_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
end subroutine amg_d_poly_smoother_descr
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_cseti(sm,what,val,info,idx)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
|
||||
implicit none
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
end subroutine amg_d_poly_smoother_cseti
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_csetc(sm,what,val,info,idx)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
|
||||
implicit none
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
end subroutine amg_d_poly_smoother_csetc
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_d_poly_smoother_csetr(sm,what,val,info,idx)
|
||||
import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, &
|
||||
& psb_dpk_, amg_d_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
|
||||
implicit none
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
end subroutine amg_d_poly_smoother_csetr
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine d_poly_smoother_free(sm,info)
|
||||
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='d_poly_smoother_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
|
||||
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%free(info)
|
||||
if (info == psb_success_) deallocate(sm%sv,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
|
||||
sm%pa => null()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine d_poly_smoother_free
|
||||
|
||||
function d_poly_smoother_sizeof(sm) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_d_poly_smoother_type), intent(in) :: sm
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = psb_sizeof_dp
|
||||
if (allocated(sm%sv)) val = val + sm%sv%sizeof()
|
||||
if (allocated(sm%poly_beta)) val = val + psb_sizeof_dp * size(sm%poly_beta)
|
||||
|
||||
return
|
||||
end function d_poly_smoother_sizeof
|
||||
|
||||
subroutine d_poly_smoother_default(sm)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
|
||||
!
|
||||
! Default: BJAC with no residual check
|
||||
!
|
||||
sm%pdegree = 1
|
||||
sm%rho_ba = -done
|
||||
sm%variant = amg_poly_lottes_
|
||||
sm%rho_estimate = amg_poly_rho_est_power_
|
||||
sm%rho_estimate_iterations = 20
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%default()
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine d_poly_smoother_default
|
||||
|
||||
function d_poly_smoother_get_nzeros(sm) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_d_poly_smoother_type), intent(in) :: sm
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = 0
|
||||
if (allocated(sm%sv)) val = val + sm%sv%get_nzeros()
|
||||
|
||||
return
|
||||
end function d_poly_smoother_get_nzeros
|
||||
|
||||
function d_poly_smoother_get_wrksize(sm) result(val)
|
||||
implicit none
|
||||
class(amg_d_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = 4
|
||||
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
|
||||
|
||||
end function d_poly_smoother_get_wrksize
|
||||
|
||||
function d_poly_smoother_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "Polynomial smoother"
|
||||
end function d_poly_smoother_get_fmt
|
||||
|
||||
function d_poly_smoother_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_poly_
|
||||
end function d_poly_smoother_get_id
|
||||
|
||||
|
||||
end module amg_d_poly_smoother
|
||||
@@ -139,6 +139,7 @@ module amg_d_prec_type
|
||||
procedure, pass(prec) :: smoothers_build => amg_d_smoothers_bld
|
||||
procedure, pass(prec) :: smoothers_free => amg_d_smoothers_free
|
||||
procedure, pass(prec) :: descr => amg_dfile_prec_descr
|
||||
procedure, pass(prec) :: memory_use => amg_dfile_prec_memory_use
|
||||
end type amg_dprec_type
|
||||
|
||||
private :: amg_d_dump, amg_d_get_compl, amg_d_cmp_compl,&
|
||||
@@ -170,6 +171,22 @@ module amg_d_prec_type
|
||||
end subroutine amg_dfile_prec_descr
|
||||
end interface
|
||||
|
||||
|
||||
interface amg_memory_use
|
||||
subroutine amg_dfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
|
||||
import :: amg_dprec_type, psb_ipk_
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_dprec_type), intent(in) :: prec
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine amg_dfile_prec_memory_use
|
||||
end interface
|
||||
|
||||
interface amg_sizeof
|
||||
module procedure amg_dprec_sizeof
|
||||
end interface
|
||||
|
||||
@@ -234,7 +234,7 @@ contains
|
||||
! Arguments
|
||||
class(amg_s_ilu_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%fact_type = psb_ilu_n_
|
||||
sv%fact_type = amg_ilu_n_
|
||||
sv%fill_in = 0
|
||||
sv%thresh = szero
|
||||
|
||||
@@ -255,13 +255,13 @@ contains
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(sv%fact_type,&
|
||||
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
|
||||
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
|
||||
|
||||
select case(sv%fact_type)
|
||||
case(psb_ilu_n_,psb_milu_n_)
|
||||
case(amg_ilu_n_,amg_milu_n_)
|
||||
call amg_check_def(sv%fill_in,&
|
||||
& 'Level',izero,is_int_non_negative)
|
||||
case(psb_ilu_t_)
|
||||
case(amg_ilu_t_)
|
||||
call amg_check_def(sv%thresh,&
|
||||
& 'Eps',szero,is_legal_s_fact_thrs)
|
||||
end select
|
||||
@@ -439,9 +439,9 @@ contains
|
||||
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
|
||||
& amg_fact_names(sv%fact_type)
|
||||
select case(sv%fact_type)
|
||||
case(psb_ilu_n_,psb_milu_n_)
|
||||
case(amg_ilu_n_,amg_milu_n_)
|
||||
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
|
||||
case(psb_ilu_t_)
|
||||
case(amg_ilu_t_)
|
||||
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
|
||||
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
|
||||
end select
|
||||
@@ -496,7 +496,7 @@ contains
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = psb_ilu_n_
|
||||
val = amg_ilu_n_
|
||||
end function s_ilu_solver_get_id
|
||||
|
||||
function s_ilu_solver_get_wrksize() result(val)
|
||||
|
||||
@@ -0,0 +1,585 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_s_jac_solver_mod.f90
|
||||
!
|
||||
! Module: amg_s_jac_solver_mod
|
||||
!
|
||||
! This module defines:
|
||||
! - the amg_s_jac_solver_type data structure containing the ingredients
|
||||
! for a local Jacobi iteration. The iterations are local to a process
|
||||
! (they operate on the block diagonal).
|
||||
!
|
||||
!
|
||||
module amg_s_jac_solver
|
||||
|
||||
use amg_s_base_solver_mod
|
||||
|
||||
type, extends(amg_s_base_solver_type) :: amg_s_jac_solver_type
|
||||
type(psb_sspmat_type) :: a
|
||||
type(psb_s_vect_type), allocatable :: dv
|
||||
real(psb_spk_), allocatable :: d(:)
|
||||
integer(psb_ipk_) :: sweeps
|
||||
real(psb_spk_) :: eps
|
||||
contains
|
||||
procedure, pass(sv) :: dump => amg_s_jac_solver_dmp
|
||||
procedure, pass(sv) :: check => s_jac_solver_check
|
||||
procedure, pass(sv) :: clone => amg_s_jac_solver_clone
|
||||
procedure, pass(sv) :: clone_settings => amg_s_jac_solver_clone_settings
|
||||
procedure, pass(sv) :: clear_data => amg_s_jac_solver_clear_data
|
||||
procedure, pass(sv) :: build => amg_s_jac_solver_bld
|
||||
procedure, pass(sv) :: cnv => amg_s_jac_solver_cnv
|
||||
procedure, pass(sv) :: apply_v => amg_s_jac_solver_apply_vect
|
||||
procedure, pass(sv) :: apply_a => amg_s_jac_solver_apply
|
||||
procedure, pass(sv) :: free => s_jac_solver_free
|
||||
procedure, pass(sv) :: cseti => s_jac_solver_cseti
|
||||
procedure, pass(sv) :: csetc => s_jac_solver_csetc
|
||||
procedure, pass(sv) :: csetr => s_jac_solver_csetr
|
||||
procedure, pass(sv) :: descr => s_jac_solver_descr
|
||||
procedure, pass(sv) :: default => s_jac_solver_default
|
||||
procedure, pass(sv) :: sizeof => s_jac_solver_sizeof
|
||||
procedure, pass(sv) :: get_nzeros => s_jac_solver_get_nzeros
|
||||
procedure, nopass :: get_wrksz => s_jac_solver_get_wrksize
|
||||
procedure, nopass :: get_fmt => s_jac_solver_get_fmt
|
||||
procedure, nopass :: get_id => s_jac_solver_get_id
|
||||
procedure, nopass :: is_iterative => s_jac_solver_is_iterative
|
||||
end type amg_s_jac_solver_type
|
||||
|
||||
type, extends(amg_s_jac_solver_type) :: amg_s_l1_jac_solver_type
|
||||
contains
|
||||
procedure, pass(sv) :: build => amg_s_l1_jac_solver_bld
|
||||
procedure, pass(sv) :: descr => s_l1_jac_solver_descr
|
||||
procedure, nopass :: get_fmt => s_l1_jac_solver_get_fmt
|
||||
procedure, nopass :: get_id => s_l1_jac_solver_get_id
|
||||
end type amg_s_l1_jac_solver_type
|
||||
|
||||
|
||||
private :: s_jac_solver_bld, s_jac_solver_apply, &
|
||||
& s_jac_solver_free, &
|
||||
& s_jac_solver_descr, s_jac_solver_sizeof, &
|
||||
& s_jac_solver_default, s_jac_solver_dmp, &
|
||||
& s_jac_solver_apply_vect, s_jac_solver_get_nzeros, &
|
||||
& s_jac_solver_get_fmt, s_jac_solver_check,&
|
||||
& s_jac_solver_is_iterative, &
|
||||
& s_jac_solver_get_id, s_jac_solver_get_wrksize
|
||||
|
||||
interface
|
||||
subroutine amg_s_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
type(psb_s_vect_type),intent(inout) :: x
|
||||
type(psb_s_vect_type),intent(inout) :: y
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_s_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_s_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_s_jac_solver_apply_vect
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
|
||||
import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
real(psb_spk_),intent(inout) :: x(:)
|
||||
real(psb_spk_),intent(inout) :: y(:)
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
real(psb_spk_),intent(inout), optional :: initu(:)
|
||||
end subroutine amg_s_jac_solver_apply
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_sspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_sspmat_type), intent(in), target, optional :: b
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_s_jac_solver_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_s_l1_jac_solver_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_sspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_s_l1_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_sspmat_type), intent(in), target, optional :: b
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_s_l1_jac_solver_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_jac_solver_cnv(sv,info,amold,vmold,imold)
|
||||
import :: amg_s_jac_solver_type, psb_spk_, &
|
||||
& psb_s_base_sparse_mat, psb_s_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_s_jac_solver_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
|
||||
import :: psb_desc_type, amg_s_jac_solver_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, &
|
||||
& psb_ipk_
|
||||
implicit none
|
||||
class(amg_s_jac_solver_type), intent(in) :: sv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: solver, global_num
|
||||
end subroutine amg_s_jac_solver_dmp
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_jac_solver_clone(sv,svout,info)
|
||||
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
|
||||
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
|
||||
& amg_s_base_solver_type, amg_s_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_jac_solver_clone
|
||||
end interface
|
||||
|
||||
!!$ interface
|
||||
!!$ subroutine amg_s_l1_jac_solver_clone(sv,svout,info)
|
||||
!!$ import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
|
||||
!!$ & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
|
||||
!!$ & amg_s_base_solver_type, amg_s_l1_jac_solver_type, psb_ipk_
|
||||
!!$ Implicit None
|
||||
!!$
|
||||
!!$ ! Arguments
|
||||
!!$ class(amg_s_l1_jac_solver_type), intent(inout) :: sv
|
||||
!!$ class(amg_s_base_solver_type), allocatable, intent(inout) :: svout
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ end subroutine amg_s_l1_jac_solver_clone
|
||||
!!$ end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_jac_solver_clone_settings(sv,svout,info)
|
||||
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
|
||||
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
|
||||
& amg_s_base_solver_type, amg_s_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
class(amg_s_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_jac_solver_clone_settings
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_jac_solver_clear_data(sv,info)
|
||||
import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, &
|
||||
& psb_s_vect_type, psb_s_base_vect_type, psb_spk_, &
|
||||
& amg_s_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_jac_solver_clear_data
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine s_jac_solver_default(sv)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%sweeps = ione
|
||||
sv%eps = dzero
|
||||
|
||||
return
|
||||
end subroutine s_jac_solver_default
|
||||
|
||||
subroutine s_jac_solver_check(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_jac_solver_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(sv%sweeps,&
|
||||
& 'Jacobi sweeps',ione,is_int_positive)
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine s_jac_solver_check
|
||||
|
||||
subroutine s_jac_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_jac_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SOLVER_SWEEPS')
|
||||
sv%sweeps = val
|
||||
case default
|
||||
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_jac_solver_cseti
|
||||
|
||||
subroutine s_jac_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, ival
|
||||
character(len=20) :: name='s_jac_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
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 s_jac_solver_csetc
|
||||
|
||||
subroutine s_jac_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_jac_solver_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SOLVER_EPS')
|
||||
sv%eps = val
|
||||
case default
|
||||
call sv%amg_s_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_jac_solver_csetr
|
||||
|
||||
subroutine s_jac_solver_free(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_jac_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%a%free()
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
if (allocated(sv%d)) deallocate(sv%d)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_jac_solver_free
|
||||
|
||||
subroutine s_jac_solver_descr(sv,info,iout,coarse,prefix)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_s_jac_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if (sv%eps<=dzero) then
|
||||
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',&
|
||||
& sv%sweeps,' sweeps'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',&
|
||||
& sv%eps,' and maxit', sv%sweeps
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_jac_solver_descr
|
||||
|
||||
function s_jac_solver_get_nzeros(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = 0
|
||||
val = val + sv%a%get_nzeros()
|
||||
val = val + sv%dv%get_nrows()
|
||||
|
||||
return
|
||||
end function s_jac_solver_get_nzeros
|
||||
|
||||
function s_jac_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_s_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = psb_sizeof_ip
|
||||
val = val + sv%a%sizeof()
|
||||
val = val + sv%dv%sizeof()
|
||||
|
||||
return
|
||||
end function s_jac_solver_sizeof
|
||||
|
||||
function s_jac_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "Jacobi solver"
|
||||
end function s_jac_solver_get_fmt
|
||||
|
||||
function s_jac_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_jac_
|
||||
end function s_jac_solver_get_id
|
||||
|
||||
!
|
||||
! If this is true, then the solver needs a starting
|
||||
! guess. Currently only handled in JAC smoother.
|
||||
!
|
||||
function s_jac_solver_is_iterative() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function s_jac_solver_is_iterative
|
||||
|
||||
function s_jac_solver_get_wrksize() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = 2
|
||||
end function s_jac_solver_get_wrksize
|
||||
|
||||
subroutine s_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_l1_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_s_l1_jac_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if (sv%eps<=dzero) then
|
||||
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',&
|
||||
& sv%sweeps,' sweeps'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',&
|
||||
& sv%eps,' and maxit', sv%sweeps
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_l1_jac_solver_descr
|
||||
|
||||
function s_l1_jac_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "L1-Jacobi solver"
|
||||
end function s_l1_jac_solver_get_fmt
|
||||
|
||||
function s_l1_jac_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_l1_jac_
|
||||
end function s_l1_jac_solver_get_id
|
||||
|
||||
end module amg_s_jac_solver
|
||||
@@ -143,9 +143,10 @@ contains
|
||||
type(psb_ls_coo_sparse_mat) :: tmpcoo
|
||||
logical :: display_out_, print_out_, reproducible_
|
||||
logical, parameter :: dump=.false., debug=.false., dump_mate=.false., &
|
||||
& debug_ilaggr=.false., debug_sync=.false.
|
||||
& debug_ilaggr=.false., debug_sync=.false., debug_mate=.false.
|
||||
integer(psb_ipk_), save :: idx_bldmtc=-1, idx_phase1=-1, idx_phase2=-1, idx_phase3=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
integer, parameter :: ilaggr_neginit=-1, ilaggr_nonlocal=-2
|
||||
|
||||
ictxt = desc_a%get_ctxt()
|
||||
call psb_info(ictxt,iam,np)
|
||||
@@ -187,7 +188,7 @@ contains
|
||||
call desc_a%l2gip(ilv,info,owned=.false.)
|
||||
|
||||
call psb_geall(ilaggr,desc_a,info)
|
||||
ilaggr = -1
|
||||
ilaggr = ilaggr_neginit
|
||||
call psb_geasb(ilaggr,desc_a,info)
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -213,7 +214,20 @@ contains
|
||||
call psb_barrier(ictxt)
|
||||
if (iam == 0) write(0,*)' out from buildmatching:', info
|
||||
end if
|
||||
|
||||
if (debug_mate) then
|
||||
block
|
||||
integer(psb_lpk_), allocatable :: ckmate(:)
|
||||
allocate(ckmate(nr))
|
||||
ckmate(1:nr) = mate(1:nr)
|
||||
call psb_msort(ckmate(1:nr))
|
||||
do i=1,nr-1
|
||||
if ((ckmate(i)>0) .and. (ckmate(i) == ckmate(i+1))) then
|
||||
write(0,*) iam,' Duplicate mate entry at',i,' :',ckmate(i)
|
||||
end if
|
||||
end do
|
||||
end block
|
||||
end if
|
||||
|
||||
if (info == 0) then
|
||||
if (do_timings) call psb_tic(idx_phase2)
|
||||
if (debug_sync) then
|
||||
@@ -258,16 +272,14 @@ contains
|
||||
write(0,*) 'Impossible: mate(k) > nc'
|
||||
cycle
|
||||
else
|
||||
|
||||
if (ilaggr(k) == -1) then
|
||||
|
||||
if (ilaggr(k) == ilaggr_neginit) then
|
||||
wk = w(k)
|
||||
widx = w(idx)
|
||||
wmax = max(abs(wk),abs(widx))
|
||||
nrmagg = wmax*sqrt((wk/wmax)**2+(widx/wmax)**2)
|
||||
if (nrmagg > epsilon(nrmagg)) then
|
||||
if (idx <= nr) then
|
||||
if (ilaggr(idx) == -1) then
|
||||
if (ilaggr(idx) == ilaggr_neginit) then
|
||||
! Now, if both vertices are local, the aggregate is local
|
||||
! (kinda obvious).
|
||||
nlaggr(iam) = nlaggr(iam) + 1
|
||||
@@ -275,6 +287,9 @@ contains
|
||||
ilaggr(idx) = nlaggr(iam)
|
||||
wtemp(k) = w(k)/nrmagg
|
||||
wtemp(idx) = w(idx)/nrmagg
|
||||
else
|
||||
write(0,*) iam,' Inconsistent mate? ',k,mate(k),idx,&
|
||||
&mate(idx),ilaggr(idx)
|
||||
end if
|
||||
nlpairs = nlpairs+1
|
||||
else if (idx <= nc) then
|
||||
@@ -294,7 +309,7 @@ contains
|
||||
ilaggr(k) = nlaggr(iam)
|
||||
nlpairs = nlpairs+1
|
||||
else
|
||||
ilaggr(k) = -2
|
||||
ilaggr(k) = ilaggr_nonlocal
|
||||
end if
|
||||
else
|
||||
! Use a statistically unbiased tie-breaking rule,
|
||||
@@ -309,7 +324,7 @@ contains
|
||||
ilaggr(k) = nlaggr(iam)
|
||||
nlpairs = nlpairs+1
|
||||
else
|
||||
ilaggr(k) = -2
|
||||
ilaggr(k) = ilaggr_nonlocal
|
||||
end if
|
||||
end if
|
||||
end if
|
||||
@@ -325,6 +340,12 @@ contains
|
||||
nlsingl = nlsingl + 1
|
||||
end if
|
||||
end if
|
||||
if (ilaggr(k) == ilaggr_neginit) then
|
||||
write(0,*) iam,' Error: no update to ',k,mate(k),&
|
||||
& abs(w(k)),nrmagg,epsilon(nrmagg),wtemp(k)
|
||||
end if
|
||||
else
|
||||
if (ilaggr(k)<0) write(0,*) 'Strange? ',k,ilaggr(k)
|
||||
end if
|
||||
end if
|
||||
end do
|
||||
@@ -332,7 +353,7 @@ contains
|
||||
if (do_timings) call psb_tic(idx_phase3)
|
||||
|
||||
! Ok, now compute offsets, gather halo and fix non-local
|
||||
! aggregates (those where ilaggr == -2)
|
||||
! aggregates (those where ilaggr == ilaggr_nonlocal)
|
||||
call psb_sum(ictxt,nlaggr)
|
||||
ntaggr = sum(nlaggr(0:np-1))
|
||||
naggrm1 = sum(nlaggr(0:iam-1))
|
||||
@@ -347,7 +368,7 @@ contains
|
||||
call psb_halo(wtemp,desc_a,info)
|
||||
! Cleanup as yet unmarked entries
|
||||
do k=1,nr
|
||||
if (ilaggr(k) == -2) then
|
||||
if (ilaggr(k) == ilaggr_nonlocal) then
|
||||
idx = mate(k)
|
||||
if (idx > nr) then
|
||||
i = ilaggr(idx)
|
||||
@@ -359,9 +380,14 @@ contains
|
||||
else
|
||||
write(0,*) 'Error : unresolved (paired) index ',k,idx,i,nr,nc, ilv(k),ilv(idx)
|
||||
end if
|
||||
end if
|
||||
if (ilaggr(k) <0) then
|
||||
write(0,*) 'Matchboxp: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
|
||||
else if (ilaggr(k) <0) then
|
||||
write(0,*) iam,'Matchboxp: Funny number: ',k,ilv(k),ilaggr(k),wtemp(k)
|
||||
write(0,*) iam,' : : ',nr,nc,mate(k)
|
||||
if (mate(k) <= nr) then
|
||||
write(0,*) iam,' : : ',ilaggr(mate(k)),mate(mate(k)),&
|
||||
& ilv(k),ilv(mate(k)), ilv(mate(mate(k))),ilaggr(mate(mate(k)))
|
||||
end if
|
||||
flush(0)
|
||||
end if
|
||||
end do
|
||||
if (debug_sync) then
|
||||
@@ -414,7 +440,7 @@ contains
|
||||
|
||||
end block
|
||||
if (iam == 0) then
|
||||
write(0,*) 'Matching statistics: Unmatched nodes ',&
|
||||
write(0,*) iam,'Matching statistics: Unmatched nodes ',&
|
||||
& nunmatched,' Singletons:',nlsingl,' Pairs:',nlpairs
|
||||
end if
|
||||
|
||||
|
||||
@@ -78,7 +78,8 @@ module amg_s_mumps_solver
|
||||
!
|
||||
! Controls to be set before MUMPS instantiation:
|
||||
!
|
||||
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: LOCAL 1==amg_global_solver_: GLOBAL
|
||||
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: 'LOCAL_SOLVER
|
||||
! 1==amg_global_solver_: 'GLOBAL_SOLVER'
|
||||
! IPAR(2) : MUMPS_PRINT_ERR print verbosity (see MUMPS)
|
||||
! IPAR(3) : MUMPS_SYM 0: non-symmetric 2: symmetric
|
||||
integer(psb_ipk_), dimension(3) :: ipar
|
||||
|
||||
@@ -188,6 +188,7 @@ module amg_s_onelev_mod
|
||||
procedure, pass(lv) :: clone => s_base_onelev_clone
|
||||
procedure, pass(lv) :: cnv => amg_s_base_onelev_cnv
|
||||
procedure, pass(lv) :: descr => amg_s_base_onelev_descr
|
||||
procedure, pass(lv) :: memory_use => amg_s_base_onelev_memory_use
|
||||
procedure, pass(lv) :: default => s_base_onelev_default
|
||||
procedure, pass(lv) :: free => amg_s_base_onelev_free
|
||||
procedure, pass(lv) :: free_smoothers => amg_s_base_onelev_free_smoothers
|
||||
@@ -274,6 +275,23 @@ module amg_s_onelev_mod
|
||||
end subroutine amg_s_base_onelev_descr
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_slinmap_type, psb_spk_, amg_s_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_s_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine amg_s_base_onelev_memory_use
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
import :: amg_s_onelev_type, psb_s_base_vect_type, psb_spk_, &
|
||||
|
||||
@@ -0,0 +1,374 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Daniela di Serafino
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_s_poly_smoother_mod.f90
|
||||
!
|
||||
! Module: amg_s_poly_smoother_mod
|
||||
!
|
||||
! This module defines:
|
||||
! the amg_s_poly_smoother_type data structure containing the
|
||||
! smoother for a Jacobi/block Jacobi smoother.
|
||||
! The smoother stores in ND the block off-diagonal matrix.
|
||||
! One special case is treated separately, when the solver is DIAG or L1-DIAG
|
||||
! then the ND is the entire off-diagonal part of the matrix (including the
|
||||
! main diagonal block), so that it becomes possible to implement
|
||||
! a pure Jacobi or L1-Jacobi global solver.
|
||||
!
|
||||
module amg_s_poly_smoother
|
||||
use amg_s_base_smoother_mod
|
||||
use amg_d_poly_coeff_mod
|
||||
|
||||
type, extends(amg_s_base_smoother_type) :: amg_s_poly_smoother_type
|
||||
! The local solver component is inherited from the
|
||||
! parent type.
|
||||
! class(amg_s_base_solver_type), allocatable :: sv
|
||||
!
|
||||
integer(psb_ipk_) :: pdegree, variant
|
||||
integer(psb_ipk_) :: rho_estimate=amg_poly_rho_est_power_
|
||||
integer(psb_ipk_) :: rho_estimate_iterations=10
|
||||
type(psb_sspmat_type), pointer :: pa => null()
|
||||
real(psb_spk_), allocatable :: poly_beta(:)
|
||||
real(psb_spk_) :: cf_a = szero
|
||||
real(psb_spk_) :: rho_ba = -sone
|
||||
contains
|
||||
procedure, pass(sm) :: apply_v => amg_s_poly_smoother_apply_vect
|
||||
!!$ procedure, pass(sm) :: apply_a => amg_s_poly_smoother_apply
|
||||
procedure, pass(sm) :: dump => amg_s_poly_smoother_dmp
|
||||
procedure, pass(sm) :: build => amg_s_poly_smoother_bld
|
||||
procedure, pass(sm) :: cnv => amg_s_poly_smoother_cnv
|
||||
procedure, pass(sm) :: clone => amg_s_poly_smoother_clone
|
||||
procedure, pass(sm) :: clone_settings => amg_s_poly_smoother_clone_settings
|
||||
procedure, pass(sm) :: clear_data => amg_s_poly_smoother_clear_data
|
||||
procedure, pass(sm) :: free => s_poly_smoother_free
|
||||
procedure, pass(sm) :: cseti => amg_s_poly_smoother_cseti
|
||||
procedure, pass(sm) :: csetc => amg_s_poly_smoother_csetc
|
||||
procedure, pass(sm) :: csetr => amg_s_poly_smoother_csetr
|
||||
procedure, pass(sm) :: descr => amg_s_poly_smoother_descr
|
||||
procedure, pass(sm) :: sizeof => s_poly_smoother_sizeof
|
||||
procedure, pass(sm) :: default => s_poly_smoother_default
|
||||
procedure, pass(sm) :: get_nzeros => s_poly_smoother_get_nzeros
|
||||
procedure, pass(sm) :: get_wrksz => s_poly_smoother_get_wrksize
|
||||
procedure, nopass :: get_fmt => s_poly_smoother_get_fmt
|
||||
procedure, nopass :: get_id => s_poly_smoother_get_id
|
||||
end type amg_s_poly_smoother_type
|
||||
private :: s_poly_smoother_free, &
|
||||
& s_poly_smoother_sizeof, s_poly_smoother_get_nzeros, &
|
||||
& s_poly_smoother_get_fmt, s_poly_smoother_get_id, &
|
||||
& s_poly_smoother_get_wrksize
|
||||
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
& sweeps,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
|
||||
& psb_ipk_
|
||||
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
type(psb_s_vect_type),intent(inout) :: x
|
||||
type(psb_s_vect_type),intent(inout) :: y
|
||||
real(psb_spk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
integer(psb_ipk_), intent(in) :: sweeps
|
||||
real(psb_spk_),target, intent(inout) :: work(:)
|
||||
type(psb_s_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_s_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_s_poly_smoother_apply_vect
|
||||
end interface
|
||||
|
||||
!!$ interface
|
||||
!!$ subroutine amg_s_poly_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,&
|
||||
!!$ & sweeps,work,info,init,initu)
|
||||
!!$ import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
|
||||
!!$ & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, &
|
||||
!!$ & psb_ipk_
|
||||
!!$ type(psb_desc_type), intent(in) :: desc_data
|
||||
!!$ class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
!!$ real(psb_spk_),intent(inout) :: x(:)
|
||||
!!$ real(psb_spk_),intent(inout) :: y(:)
|
||||
!!$ real(psb_spk_),intent(in) :: alpha,beta
|
||||
!!$ character(len=1),intent(in) :: trans
|
||||
!!$ integer(psb_ipk_), intent(in) :: sweeps
|
||||
!!$ real(psb_spk_),target, intent(inout) :: work(:)
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ character, intent(in), optional :: init
|
||||
!!$ real(psb_spk_),intent(inout), optional :: initu(:)
|
||||
!!$ end subroutine amg_s_poly_smoother_apply
|
||||
!!$ end interface
|
||||
!!$
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_bld(a,desc_a,sm,info,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_s_poly_smoother_type, psb_s_vect_type, psb_spk_, &
|
||||
& psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
type(psb_sspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_s_poly_smoother_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_cnv(sm,info,amold,vmold,imold)
|
||||
import :: amg_s_poly_smoother_type, psb_spk_, &
|
||||
& psb_s_base_sparse_mat, psb_s_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_s_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_s_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_s_poly_smoother_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_dmp(sm,desc,level,info,prefix,head,smoother,solver,global_num)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, &
|
||||
& psb_ipk_
|
||||
implicit none
|
||||
class(amg_s_poly_smoother_type), intent(in) :: sm
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: smoother, solver, global_num
|
||||
end subroutine amg_s_poly_smoother_dmp
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_clone(sm,smout,info)
|
||||
import :: amg_s_poly_smoother_type, psb_spk_, &
|
||||
& amg_s_base_smoother_type, psb_ipk_
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_poly_smoother_clone
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_clone_settings(sm,smout,info)
|
||||
import :: amg_s_poly_smoother_type, psb_spk_, &
|
||||
& amg_s_base_smoother_type, psb_ipk_
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
class(amg_s_base_smoother_type), allocatable, intent(inout) :: smout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_poly_smoother_clone_settings
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_clear_data(sm,info)
|
||||
import :: amg_s_poly_smoother_type, psb_spk_, &
|
||||
& amg_s_base_smoother_type, psb_ipk_
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_s_poly_smoother_clear_data
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_descr(sm,info,iout,coarse,prefix)
|
||||
import :: amg_s_poly_smoother_type, psb_ipk_
|
||||
class(amg_s_poly_smoother_type), intent(in) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
end subroutine amg_s_poly_smoother_descr
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_cseti(sm,what,val,info,idx)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
|
||||
implicit none
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
end subroutine amg_s_poly_smoother_cseti
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_csetc(sm,what,val,info,idx)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
|
||||
implicit none
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
end subroutine amg_s_poly_smoother_csetc
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_s_poly_smoother_csetr(sm,what,val,info,idx)
|
||||
import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, &
|
||||
& psb_spk_, amg_s_poly_smoother_type, psb_epk_, psb_desc_type, psb_ipk_
|
||||
implicit none
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_spk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
end subroutine amg_s_poly_smoother_csetr
|
||||
end interface
|
||||
|
||||
|
||||
contains
|
||||
|
||||
|
||||
subroutine s_poly_smoother_free(sm,info)
|
||||
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='s_poly_smoother_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
|
||||
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%free(info)
|
||||
if (info == psb_success_) deallocate(sm%sv,stat=info)
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_alloc_dealloc_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
end if
|
||||
if (allocated(sm%poly_beta)) deallocate(sm%poly_beta)
|
||||
sm%pa => null()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine s_poly_smoother_free
|
||||
|
||||
function s_poly_smoother_sizeof(sm) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(in) :: sm
|
||||
integer(psb_epk_) :: val
|
||||
|
||||
val = psb_sizeof_dp
|
||||
if (allocated(sm%sv)) val = val + sm%sv%sizeof()
|
||||
if (allocated(sm%poly_beta)) val = val + psb_sizeof_dp * size(sm%poly_beta)
|
||||
|
||||
return
|
||||
end function s_poly_smoother_sizeof
|
||||
|
||||
subroutine s_poly_smoother_default(sm)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
|
||||
!
|
||||
! Default: BJAC with no residual check
|
||||
!
|
||||
sm%pdegree = 1
|
||||
sm%rho_ba = -sone
|
||||
sm%variant = amg_poly_lottes_
|
||||
sm%rho_estimate = amg_poly_rho_est_power_
|
||||
sm%rho_estimate_iterations = 20
|
||||
if (allocated(sm%sv)) then
|
||||
call sm%sv%default()
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine s_poly_smoother_default
|
||||
|
||||
function s_poly_smoother_get_nzeros(sm) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_s_poly_smoother_type), intent(in) :: sm
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = 0
|
||||
if (allocated(sm%sv)) val = val + sm%sv%get_nzeros()
|
||||
|
||||
return
|
||||
end function s_poly_smoother_get_nzeros
|
||||
|
||||
function s_poly_smoother_get_wrksize(sm) result(val)
|
||||
implicit none
|
||||
class(amg_s_poly_smoother_type), intent(inout) :: sm
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = 4
|
||||
if (allocated(sm%sv)) val = val + sm%sv%get_wrksz()
|
||||
|
||||
end function s_poly_smoother_get_wrksize
|
||||
|
||||
function s_poly_smoother_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "Polynomial smoother"
|
||||
end function s_poly_smoother_get_fmt
|
||||
|
||||
function s_poly_smoother_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_poly_
|
||||
end function s_poly_smoother_get_id
|
||||
|
||||
|
||||
end module amg_s_poly_smoother
|
||||
@@ -139,6 +139,7 @@ module amg_s_prec_type
|
||||
procedure, pass(prec) :: smoothers_build => amg_s_smoothers_bld
|
||||
procedure, pass(prec) :: smoothers_free => amg_s_smoothers_free
|
||||
procedure, pass(prec) :: descr => amg_sfile_prec_descr
|
||||
procedure, pass(prec) :: memory_use => amg_sfile_prec_memory_use
|
||||
end type amg_sprec_type
|
||||
|
||||
private :: amg_s_dump, amg_s_get_compl, amg_s_cmp_compl,&
|
||||
@@ -170,6 +171,22 @@ module amg_s_prec_type
|
||||
end subroutine amg_sfile_prec_descr
|
||||
end interface
|
||||
|
||||
|
||||
interface amg_memory_use
|
||||
subroutine amg_sfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
|
||||
import :: amg_sprec_type, psb_ipk_
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_sprec_type), intent(in) :: prec
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine amg_sfile_prec_memory_use
|
||||
end interface
|
||||
|
||||
interface amg_sizeof
|
||||
module procedure amg_sprec_sizeof
|
||||
end interface
|
||||
|
||||
@@ -234,7 +234,7 @@ contains
|
||||
! Arguments
|
||||
class(amg_z_ilu_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%fact_type = psb_ilu_n_
|
||||
sv%fact_type = amg_ilu_n_
|
||||
sv%fill_in = 0
|
||||
sv%thresh = dzero
|
||||
|
||||
@@ -255,13 +255,13 @@ contains
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(sv%fact_type,&
|
||||
& 'Factorization',psb_ilu_n_,is_legal_ilu_fact)
|
||||
& 'Factorization',amg_ilu_n_,is_legal_ilu_fact)
|
||||
|
||||
select case(sv%fact_type)
|
||||
case(psb_ilu_n_,psb_milu_n_)
|
||||
case(amg_ilu_n_,amg_milu_n_)
|
||||
call amg_check_def(sv%fill_in,&
|
||||
& 'Level',izero,is_int_non_negative)
|
||||
case(psb_ilu_t_)
|
||||
case(amg_ilu_t_)
|
||||
call amg_check_def(sv%thresh,&
|
||||
& 'Eps',dzero,is_legal_d_fact_thrs)
|
||||
end select
|
||||
@@ -439,9 +439,9 @@ contains
|
||||
write(iout_,*) trim(prefix_), ' Incomplete factorization solver: ',&
|
||||
& amg_fact_names(sv%fact_type)
|
||||
select case(sv%fact_type)
|
||||
case(psb_ilu_n_,psb_milu_n_)
|
||||
case(amg_ilu_n_,amg_milu_n_)
|
||||
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
|
||||
case(psb_ilu_t_)
|
||||
case(amg_ilu_t_)
|
||||
write(iout_,*) trim(prefix_), ' Fill level:',sv%fill_in
|
||||
write(iout_,*) trim(prefix_), ' Fill threshold :',sv%thresh
|
||||
end select
|
||||
@@ -496,7 +496,7 @@ contains
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = psb_ilu_n_
|
||||
val = amg_ilu_n_
|
||||
end function z_ilu_solver_get_id
|
||||
|
||||
function z_ilu_solver_get_wrksize() result(val)
|
||||
|
||||
@@ -0,0 +1,585 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_z_jac_solver_mod.f90
|
||||
!
|
||||
! Module: amg_z_jac_solver_mod
|
||||
!
|
||||
! This module defines:
|
||||
! - the amg_z_jac_solver_type data structure containing the ingredients
|
||||
! for a local Jacobi iteration. The iterations are local to a process
|
||||
! (they operate on the block diagonal).
|
||||
!
|
||||
!
|
||||
module amg_z_jac_solver
|
||||
|
||||
use amg_z_base_solver_mod
|
||||
|
||||
type, extends(amg_z_base_solver_type) :: amg_z_jac_solver_type
|
||||
type(psb_zspmat_type) :: a
|
||||
type(psb_z_vect_type), allocatable :: dv
|
||||
complex(psb_dpk_), allocatable :: d(:)
|
||||
integer(psb_ipk_) :: sweeps
|
||||
real(psb_dpk_) :: eps
|
||||
contains
|
||||
procedure, pass(sv) :: dump => amg_z_jac_solver_dmp
|
||||
procedure, pass(sv) :: check => z_jac_solver_check
|
||||
procedure, pass(sv) :: clone => amg_z_jac_solver_clone
|
||||
procedure, pass(sv) :: clone_settings => amg_z_jac_solver_clone_settings
|
||||
procedure, pass(sv) :: clear_data => amg_z_jac_solver_clear_data
|
||||
procedure, pass(sv) :: build => amg_z_jac_solver_bld
|
||||
procedure, pass(sv) :: cnv => amg_z_jac_solver_cnv
|
||||
procedure, pass(sv) :: apply_v => amg_z_jac_solver_apply_vect
|
||||
procedure, pass(sv) :: apply_a => amg_z_jac_solver_apply
|
||||
procedure, pass(sv) :: free => z_jac_solver_free
|
||||
procedure, pass(sv) :: cseti => z_jac_solver_cseti
|
||||
procedure, pass(sv) :: csetc => z_jac_solver_csetc
|
||||
procedure, pass(sv) :: csetr => z_jac_solver_csetr
|
||||
procedure, pass(sv) :: descr => z_jac_solver_descr
|
||||
procedure, pass(sv) :: default => z_jac_solver_default
|
||||
procedure, pass(sv) :: sizeof => z_jac_solver_sizeof
|
||||
procedure, pass(sv) :: get_nzeros => z_jac_solver_get_nzeros
|
||||
procedure, nopass :: get_wrksz => z_jac_solver_get_wrksize
|
||||
procedure, nopass :: get_fmt => z_jac_solver_get_fmt
|
||||
procedure, nopass :: get_id => z_jac_solver_get_id
|
||||
procedure, nopass :: is_iterative => z_jac_solver_is_iterative
|
||||
end type amg_z_jac_solver_type
|
||||
|
||||
type, extends(amg_z_jac_solver_type) :: amg_z_l1_jac_solver_type
|
||||
contains
|
||||
procedure, pass(sv) :: build => amg_z_l1_jac_solver_bld
|
||||
procedure, pass(sv) :: descr => z_l1_jac_solver_descr
|
||||
procedure, nopass :: get_fmt => z_l1_jac_solver_get_fmt
|
||||
procedure, nopass :: get_id => z_l1_jac_solver_get_id
|
||||
end type amg_z_l1_jac_solver_type
|
||||
|
||||
|
||||
private :: z_jac_solver_bld, z_jac_solver_apply, &
|
||||
& z_jac_solver_free, &
|
||||
& z_jac_solver_descr, z_jac_solver_sizeof, &
|
||||
& z_jac_solver_default, z_jac_solver_dmp, &
|
||||
& z_jac_solver_apply_vect, z_jac_solver_get_nzeros, &
|
||||
& z_jac_solver_get_fmt, z_jac_solver_check,&
|
||||
& z_jac_solver_is_iterative, &
|
||||
& z_jac_solver_get_id, z_jac_solver_get_wrksize
|
||||
|
||||
interface
|
||||
subroutine amg_z_jac_solver_apply_vect(alpha,sv,x,beta,y,desc_data,&
|
||||
& trans,work,wv,info,init,initu)
|
||||
import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
type(psb_z_vect_type),intent(inout) :: x
|
||||
type(psb_z_vect_type),intent(inout) :: y
|
||||
complex(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_dpk_),target, intent(inout) :: work(:)
|
||||
type(psb_z_vect_type),intent(inout) :: wv(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
type(psb_z_vect_type),intent(inout), optional :: initu
|
||||
end subroutine amg_z_jac_solver_apply_vect
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_jac_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu)
|
||||
import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_
|
||||
implicit none
|
||||
type(psb_desc_type), intent(in) :: desc_data
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
complex(psb_dpk_),intent(inout) :: x(:)
|
||||
complex(psb_dpk_),intent(inout) :: y(:)
|
||||
complex(psb_dpk_),intent(in) :: alpha,beta
|
||||
character(len=1),intent(in) :: trans
|
||||
complex(psb_dpk_),target, intent(inout) :: work(:)
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character, intent(in), optional :: init
|
||||
complex(psb_dpk_),intent(inout), optional :: initu(:)
|
||||
end subroutine amg_z_jac_solver_apply
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_zspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_zspmat_type), intent(in), target, optional :: b
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_z_jac_solver_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_l1_jac_solver_bld(a,desc_a,sv,info,b,amold,vmold,imold)
|
||||
import :: psb_desc_type, amg_z_l1_jac_solver_type, psb_z_vect_type, psb_dpk_, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
type(psb_zspmat_type), intent(in), target :: a
|
||||
Type(psb_desc_type), Intent(inout) :: desc_a
|
||||
class(amg_z_l1_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
type(psb_zspmat_type), intent(in), target, optional :: b
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_z_l1_jac_solver_bld
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_jac_solver_cnv(sv,info,amold,vmold,imold)
|
||||
import :: amg_z_jac_solver_type, psb_dpk_, &
|
||||
& psb_z_base_sparse_mat, psb_z_base_vect_type,&
|
||||
& psb_ipk_, psb_i_base_vect_type
|
||||
implicit none
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
class(psb_z_base_sparse_mat), intent(in), optional :: amold
|
||||
class(psb_z_base_vect_type), intent(in), optional :: vmold
|
||||
class(psb_i_base_vect_type), intent(in), optional :: imold
|
||||
end subroutine amg_z_jac_solver_cnv
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_jac_solver_dmp(sv,desc,level,info,prefix,head,solver,global_num)
|
||||
import :: psb_desc_type, amg_z_jac_solver_type, psb_z_vect_type, psb_dpk_, &
|
||||
& psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, &
|
||||
& psb_ipk_
|
||||
implicit none
|
||||
class(amg_z_jac_solver_type), intent(in) :: sv
|
||||
type(psb_desc_type), intent(in) :: desc
|
||||
integer(psb_ipk_), intent(in) :: level
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
character(len=*), intent(in), optional :: prefix, head
|
||||
logical, optional, intent(in) :: solver, global_num
|
||||
end subroutine amg_z_jac_solver_dmp
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_jac_solver_clone(sv,svout,info)
|
||||
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
|
||||
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
|
||||
& amg_z_base_solver_type, amg_z_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_z_jac_solver_clone
|
||||
end interface
|
||||
|
||||
!!$ interface
|
||||
!!$ subroutine amg_z_l1_jac_solver_clone(sv,svout,info)
|
||||
!!$ import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
|
||||
!!$ & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
|
||||
!!$ & amg_z_base_solver_type, amg_z_l1_jac_solver_type, psb_ipk_
|
||||
!!$ Implicit None
|
||||
!!$
|
||||
!!$ ! Arguments
|
||||
!!$ class(amg_z_l1_jac_solver_type), intent(inout) :: sv
|
||||
!!$ class(amg_z_base_solver_type), allocatable, intent(inout) :: svout
|
||||
!!$ integer(psb_ipk_), intent(out) :: info
|
||||
!!$ end subroutine amg_z_l1_jac_solver_clone
|
||||
!!$ end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_jac_solver_clone_settings(sv,svout,info)
|
||||
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
|
||||
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
|
||||
& amg_z_base_solver_type, amg_z_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
class(amg_z_base_solver_type), intent(inout) :: svout
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_z_jac_solver_clone_settings
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_jac_solver_clear_data(sv,info)
|
||||
import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, &
|
||||
& psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, &
|
||||
& amg_z_jac_solver_type, psb_ipk_
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
end subroutine amg_z_jac_solver_clear_data
|
||||
end interface
|
||||
|
||||
contains
|
||||
|
||||
subroutine z_jac_solver_default(sv)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
|
||||
sv%sweeps = ione
|
||||
sv%eps = dzero
|
||||
|
||||
return
|
||||
end subroutine z_jac_solver_default
|
||||
|
||||
subroutine z_jac_solver_check(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_jac_solver_check'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call amg_check_def(sv%sweeps,&
|
||||
& 'Jacobi sweeps',ione,is_int_positive)
|
||||
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine z_jac_solver_check
|
||||
|
||||
subroutine z_jac_solver_cseti(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
integer(psb_ipk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_jac_solver_cseti'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SOLVER_SWEEPS')
|
||||
sv%sweeps = val
|
||||
case default
|
||||
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_jac_solver_cseti
|
||||
|
||||
subroutine z_jac_solver_csetc(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
character(len=*), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act, ival
|
||||
character(len=20) :: name='z_jac_solver_csetc'
|
||||
|
||||
info = psb_success_
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
|
||||
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
|
||||
if (info /= psb_success_) then
|
||||
info = psb_err_from_subroutine_
|
||||
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 z_jac_solver_csetc
|
||||
|
||||
subroutine z_jac_solver_csetr(sv,what,val,info,idx)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
character(len=*), intent(in) :: what
|
||||
real(psb_dpk_), intent(in) :: val
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: idx
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_jac_solver_csetr'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
select case(psb_toupper(what))
|
||||
case('SOLVER_EPS')
|
||||
sv%eps = val
|
||||
case default
|
||||
call sv%amg_z_base_solver_type%set(what,val,info,idx=idx)
|
||||
end select
|
||||
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_jac_solver_csetr
|
||||
|
||||
subroutine z_jac_solver_free(sv,info)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(inout) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20) :: name='z_jac_solver_free'
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
|
||||
call sv%a%free()
|
||||
if (allocated(sv%dv)) then
|
||||
call sv%dv%free(info)
|
||||
deallocate(sv%dv)
|
||||
end if
|
||||
if (allocated(sv%d)) deallocate(sv%d)
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_jac_solver_free
|
||||
|
||||
subroutine z_jac_solver_descr(sv,info,iout,coarse,prefix)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_z_jac_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if (sv%eps<=dzero) then
|
||||
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with ',&
|
||||
& sv%sweeps,' sweeps'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Jacobi iterative solver with tolerance',&
|
||||
& sv%eps,' and maxit', sv%sweeps
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_jac_solver_descr
|
||||
|
||||
function z_jac_solver_get_nzeros(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = 0
|
||||
val = val + sv%a%get_nzeros()
|
||||
val = val + sv%dv%get_nrows()
|
||||
|
||||
return
|
||||
end function z_jac_solver_get_nzeros
|
||||
|
||||
function z_jac_solver_sizeof(sv) result(val)
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_z_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_epk_) :: val
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
val = psb_sizeof_ip
|
||||
val = val + sv%a%sizeof()
|
||||
val = val + sv%dv%sizeof()
|
||||
|
||||
return
|
||||
end function z_jac_solver_sizeof
|
||||
|
||||
function z_jac_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "Jacobi solver"
|
||||
end function z_jac_solver_get_fmt
|
||||
|
||||
function z_jac_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_jac_
|
||||
end function z_jac_solver_get_id
|
||||
|
||||
!
|
||||
! If this is true, then the solver needs a starting
|
||||
! guess. Currently only handled in JAC smoother.
|
||||
!
|
||||
function z_jac_solver_is_iterative() result(val)
|
||||
implicit none
|
||||
logical :: val
|
||||
|
||||
val = .true.
|
||||
end function z_jac_solver_is_iterative
|
||||
|
||||
function z_jac_solver_get_wrksize() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = 2
|
||||
end function z_jac_solver_get_wrksize
|
||||
|
||||
subroutine z_l1_jac_solver_descr(sv,info,iout,coarse,prefix)
|
||||
|
||||
Implicit None
|
||||
|
||||
! Arguments
|
||||
class(amg_z_l1_jac_solver_type), intent(in) :: sv
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
logical, intent(in), optional :: coarse
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: err_act
|
||||
character(len=20), parameter :: name='amg_z_l1_jac_solver_descr'
|
||||
integer(psb_ipk_) :: iout_
|
||||
character(1024) :: prefix_
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
endif
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if (sv%eps<=dzero) then
|
||||
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with ',&
|
||||
& sv%sweeps,' sweeps'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' L1-Jacobi iterative solver with tolerance',&
|
||||
& sv%eps,' and maxit', sv%sweeps
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
end subroutine z_l1_jac_solver_descr
|
||||
|
||||
function z_l1_jac_solver_get_fmt() result(val)
|
||||
implicit none
|
||||
character(len=32) :: val
|
||||
|
||||
val = "L1-Jacobi solver"
|
||||
end function z_l1_jac_solver_get_fmt
|
||||
|
||||
function z_l1_jac_solver_get_id() result(val)
|
||||
implicit none
|
||||
integer(psb_ipk_) :: val
|
||||
|
||||
val = amg_l1_jac_
|
||||
end function z_l1_jac_solver_get_id
|
||||
|
||||
end module amg_z_jac_solver
|
||||
@@ -78,7 +78,8 @@ module amg_z_mumps_solver
|
||||
!
|
||||
! Controls to be set before MUMPS instantiation:
|
||||
!
|
||||
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: LOCAL 1==amg_global_solver_: GLOBAL
|
||||
! IPAR(1) : MUMPS_LOC_GLOB 0==amg_local_solver_: 'LOCAL_SOLVER
|
||||
! 1==amg_global_solver_: 'GLOBAL_SOLVER'
|
||||
! IPAR(2) : MUMPS_PRINT_ERR print verbosity (see MUMPS)
|
||||
! IPAR(3) : MUMPS_SYM 0: non-symmetric 2: symmetric
|
||||
integer(psb_ipk_), dimension(3) :: ipar
|
||||
|
||||
@@ -187,6 +187,7 @@ module amg_z_onelev_mod
|
||||
procedure, pass(lv) :: clone => z_base_onelev_clone
|
||||
procedure, pass(lv) :: cnv => amg_z_base_onelev_cnv
|
||||
procedure, pass(lv) :: descr => amg_z_base_onelev_descr
|
||||
procedure, pass(lv) :: memory_use => amg_z_base_onelev_memory_use
|
||||
procedure, pass(lv) :: default => z_base_onelev_default
|
||||
procedure, pass(lv) :: free => amg_z_base_onelev_free
|
||||
procedure, pass(lv) :: free_smoothers => amg_z_base_onelev_free_smoothers
|
||||
@@ -273,6 +274,23 @@ module amg_z_onelev_mod
|
||||
end subroutine amg_z_base_onelev_descr
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity, prefix,global)
|
||||
import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, &
|
||||
& psb_zlinmap_type, psb_dpk_, amg_z_onelev_type, &
|
||||
& psb_ipk_, psb_epk_, psb_desc_type
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_z_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine amg_z_base_onelev_memory_use
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine amg_z_base_onelev_cnv(lv,info,amold,vmold,imold)
|
||||
import :: amg_z_onelev_type, psb_z_base_vect_type, psb_dpk_, &
|
||||
|
||||
@@ -139,6 +139,7 @@ module amg_z_prec_type
|
||||
procedure, pass(prec) :: smoothers_build => amg_z_smoothers_bld
|
||||
procedure, pass(prec) :: smoothers_free => amg_z_smoothers_free
|
||||
procedure, pass(prec) :: descr => amg_zfile_prec_descr
|
||||
procedure, pass(prec) :: memory_use => amg_zfile_prec_memory_use
|
||||
end type amg_zprec_type
|
||||
|
||||
private :: amg_z_dump, amg_z_get_compl, amg_z_cmp_compl,&
|
||||
@@ -170,6 +171,22 @@ module amg_z_prec_type
|
||||
end subroutine amg_zfile_prec_descr
|
||||
end interface
|
||||
|
||||
|
||||
interface amg_memory_use
|
||||
subroutine amg_zfile_prec_memory_use(prec,info,iout,root,verbosity,prefix,global)
|
||||
import :: amg_zprec_type, psb_ipk_
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_zprec_type), intent(in) :: prec
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
end subroutine amg_zfile_prec_memory_use
|
||||
end interface
|
||||
|
||||
interface amg_sizeof
|
||||
module procedure amg_zprec_sizeof
|
||||
end interface
|
||||
|
||||
@@ -22,22 +22,22 @@ MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS)
|
||||
MPCOBJS=amg_dslud_interface.o amg_zslud_interface.o
|
||||
|
||||
|
||||
DINNEROBJS= amg_dmlprec_bld.o amg_dfile_prec_descr.o \
|
||||
DINNEROBJS= amg_dmlprec_bld.o amg_dfile_prec_descr.o amg_dfile_prec_memory_use.o \
|
||||
amg_d_smoothers_bld.o amg_d_hierarchy_bld.o amg_d_hierarchy_rebld.o \
|
||||
amg_dmlprec_aply.o \
|
||||
$(DMPFOBJS) amg_d_extprol_bld.o
|
||||
|
||||
SINNEROBJS= amg_smlprec_bld.o amg_sfile_prec_descr.o \
|
||||
SINNEROBJS= amg_smlprec_bld.o amg_sfile_prec_descr.o amg_sfile_prec_memory_use.o \
|
||||
amg_s_smoothers_bld.o amg_s_hierarchy_bld.o amg_s_hierarchy_rebld.o \
|
||||
amg_smlprec_aply.o \
|
||||
$(SMPFOBJS) amg_s_extprol_bld.o
|
||||
|
||||
ZINNEROBJS= amg_zmlprec_bld.o amg_zfile_prec_descr.o \
|
||||
ZINNEROBJS= amg_zmlprec_bld.o amg_zfile_prec_descr.o amg_zfile_prec_memory_use.o \
|
||||
amg_z_smoothers_bld.o amg_z_hierarchy_bld.o amg_z_hierarchy_rebld.o \
|
||||
amg_zmlprec_aply.o \
|
||||
$(ZMPFOBJS) amg_z_extprol_bld.o
|
||||
|
||||
CINNEROBJS= amg_cmlprec_bld.o amg_cfile_prec_descr.o \
|
||||
CINNEROBJS= amg_cmlprec_bld.o amg_cfile_prec_descr.o amg_cfile_prec_memory_use.o \
|
||||
amg_c_smoothers_bld.o amg_c_hierarchy_bld.o amg_c_hierarchy_rebld.o \
|
||||
amg_cmlprec_aply.o \
|
||||
$(CMPFOBJS) amg_c_extprol_bld.o
|
||||
|
||||
@@ -62,7 +62,22 @@ amg_s_parmatch_smth_bld.o \
|
||||
amg_s_parmatch_spmm_bld_inner.o
|
||||
|
||||
MPCOBJS=MatchBoxPC.o \
|
||||
algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.o
|
||||
sendBundledMessages.o \
|
||||
initialize.o \
|
||||
extractUChunk.o \
|
||||
isAlreadyMatched.o \
|
||||
findOwnerOfGhost.o \
|
||||
clean.o \
|
||||
computeCandidateMate.o \
|
||||
parallelComputeCandidateMateB.o \
|
||||
processMatchedVertices.o \
|
||||
processMatchedVerticesAndSendMessages.o \
|
||||
processCrossEdge.o \
|
||||
queueTransfer.o \
|
||||
processMessages.o \
|
||||
processExposedVertex.o \
|
||||
algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC.o \
|
||||
algoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP.o
|
||||
|
||||
OBJS = $(FOBJS) $(MPCOBJS)
|
||||
|
||||
|
||||
@@ -60,17 +60,43 @@ void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
|
||||
#if !defined(SERIAL_MPI)
|
||||
MPI_Comm C_comm=MPI_Comm_f2c(icomm);
|
||||
|
||||
#ifdef DEBUG
|
||||
fprintf(stderr,"MatchBoxPC: rank %d nlver %ld nledge %ld [ %ld %ld ]\n",
|
||||
myRank,NLVer, NLEdge,verDistance[0],verDistance[1]);
|
||||
#endif
|
||||
dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
|
||||
|
||||
|
||||
#undef TIME_TRACKER
|
||||
#ifdef TIME_TRACKER
|
||||
double tmr = MPI_Wtime();
|
||||
#endif
|
||||
|
||||
#if defined(OPENMP)
|
||||
//fprintf(stderr,"Warning: using buggy OpenMP matching!\n");
|
||||
dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge,
|
||||
verLocPtr, verLocInd, edgeLocWeight,
|
||||
verDistance, Mate,
|
||||
myRank, numProcs, C_comm,
|
||||
msgIndSent, msgActualSent, msgPercent,
|
||||
ph0_time, ph1_time, ph2_time,
|
||||
ph1_card, ph2_card );
|
||||
#else
|
||||
dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
|
||||
verLocPtr, verLocInd, edgeLocWeight,
|
||||
verDistance, Mate,
|
||||
myRank, numProcs, C_comm,
|
||||
msgIndSent, msgActualSent, msgPercent,
|
||||
ph0_time, ph1_time, ph2_time,
|
||||
ph1_card, ph2_card );
|
||||
#endif
|
||||
|
||||
|
||||
#ifdef TIME_TRACKER
|
||||
tmr = MPI_Wtime() - tmr;
|
||||
fprintf(stderr, "Elaboration time: %f for %ld nodes\n", tmr, NLVer);
|
||||
#endif
|
||||
|
||||
#endif
|
||||
}
|
||||
|
||||
@@ -88,13 +114,24 @@ void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
fprintf(stderr,"MatchBoxPC: rank %d nlver %ld nledge %ld [ %ld %ld ]\n",
|
||||
myRank,NLVer, NLEdge,verDistance[0],verDistance[1]);
|
||||
#endif
|
||||
#if defined(OPENMP)
|
||||
//fprintf(stderr,"Warning: using buggy OpenMP matching!\n");
|
||||
salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(NLVer, NLEdge,
|
||||
verLocPtr, verLocInd, edgeLocWeight,
|
||||
verDistance, Mate,
|
||||
myRank, numProcs, C_comm,
|
||||
msgIndSent, msgActualSent, msgPercent,
|
||||
ph0_time, ph1_time, ph2_time,
|
||||
ph1_card, ph2_card );
|
||||
#else
|
||||
salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(NLVer, NLEdge,
|
||||
verLocPtr, verLocInd, edgeLocWeight,
|
||||
verDistance, Mate,
|
||||
myRank, numProcs, C_comm,
|
||||
msgIndSent, msgActualSent, msgPercent,
|
||||
ph0_time, ph1_time, ph2_time,
|
||||
ph1_card, ph2_card );
|
||||
verLocPtr, verLocInd, edgeLocWeight,
|
||||
verDistance, Mate,
|
||||
myRank, numProcs, C_comm,
|
||||
msgIndSent, msgActualSent, msgPercent,
|
||||
ph0_time, ph1_time, ph2_time,
|
||||
ph1_card, ph2_card );
|
||||
#endif
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
@@ -52,145 +52,580 @@
|
||||
|
||||
#ifndef _matchboxpC_H_
|
||||
#define _matchboxpC_H_
|
||||
//Turn on a lot of debugging information with this switch:
|
||||
// Turn on a lot of debugging information with this switch:
|
||||
//#define PRINT_DEBUG_INFO_
|
||||
#include <stdio.h>
|
||||
#include <iostream>
|
||||
#include <assert.h>
|
||||
#include <map>
|
||||
#include <vector>
|
||||
// #include "matchboxp.h"
|
||||
#ifdef OPENMP
|
||||
// OpenMP is included and used if and only if the OpenMP version of the matching
|
||||
// is required
|
||||
#include "omp.h"
|
||||
#endif
|
||||
#include "primitiveDataTypeDefinitions.h"
|
||||
#include "dataStrStaticQueue.h"
|
||||
|
||||
using namespace std;
|
||||
|
||||
const int NUM_THREAD = 4;
|
||||
const int UCHUNK = 10;
|
||||
|
||||
const MilanLongInt REQUEST = 1;
|
||||
const MilanLongInt SUCCESS = 2;
|
||||
const MilanLongInt FAILURE = 3;
|
||||
const MilanLongInt SIZEINFO = 4;
|
||||
|
||||
const int ComputeTag = 7; // Predefined tag
|
||||
const int BundleTag = 9; // Predefined tag
|
||||
|
||||
static vector<MilanLongInt> DEFAULT_VECTOR;
|
||||
|
||||
// MPI type map
|
||||
template <typename T>
|
||||
MPI_Datatype TypeMap();
|
||||
template <>
|
||||
inline MPI_Datatype TypeMap<int64_t>() { return MPI_LONG_LONG; }
|
||||
template <>
|
||||
inline MPI_Datatype TypeMap<int>() { return MPI_INT; }
|
||||
template <>
|
||||
inline MPI_Datatype TypeMap<double>() { return MPI_DOUBLE; }
|
||||
template <>
|
||||
inline MPI_Datatype TypeMap<float>() { return MPI_FLOAT; }
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
extern "C"
|
||||
{
|
||||
#endif
|
||||
|
||||
#if !defined(SERIAL_MPI)
|
||||
|
||||
#define MilanMpiLongInt MPI_LONG_LONG
|
||||
|
||||
#define MilanMpiLongInt MPI_LONG_LONG
|
||||
|
||||
#ifndef _primitiveDataType_Definition_
|
||||
#define _primitiveDataType_Definition_
|
||||
//Regular integer:
|
||||
#ifndef INTEGER_H
|
||||
#define INTEGER_H
|
||||
typedef int32_t MilanInt;
|
||||
#endif
|
||||
// Regular integer:
|
||||
#ifndef INTEGER_H
|
||||
#define INTEGER_H
|
||||
typedef int32_t MilanInt;
|
||||
#endif
|
||||
|
||||
//Regular long integer:
|
||||
#ifndef LONG_INT_H
|
||||
#define LONG_INT_H
|
||||
#ifdef BIT64
|
||||
typedef int64_t MilanLongInt;
|
||||
typedef MPI_LONG MilanMpiLongInt;
|
||||
#else
|
||||
typedef int32_t MilanLongInt;
|
||||
typedef MPI_INT MilanMpiLongInt;
|
||||
#endif
|
||||
#endif
|
||||
// Regular long integer:
|
||||
#ifndef LONG_INT_H
|
||||
#define LONG_INT_H
|
||||
#ifdef BIT64
|
||||
typedef int64_t MilanLongInt;
|
||||
typedef MPI_LONG MilanMpiLongInt;
|
||||
#else
|
||||
typedef int32_t MilanLongInt;
|
||||
typedef MPI_INT MilanMpiLongInt;
|
||||
#endif
|
||||
#endif
|
||||
|
||||
//Regular boolean
|
||||
#ifndef BOOL_H
|
||||
#define BOOL_H
|
||||
typedef bool MilanBool;
|
||||
#endif
|
||||
// Regular boolean
|
||||
#ifndef BOOL_H
|
||||
#define BOOL_H
|
||||
typedef bool MilanBool;
|
||||
#endif
|
||||
|
||||
//Regular double and absolute value computation:
|
||||
#ifndef REAL_H
|
||||
#define REAL_H
|
||||
typedef double MilanReal;
|
||||
typedef MPI_DOUBLE MilanMpiReal;
|
||||
inline MilanReal MilanAbs(MilanReal value)
|
||||
{
|
||||
return fabs(value);
|
||||
}
|
||||
#endif
|
||||
// Regular double and absolute value computation:
|
||||
#ifndef REAL_H
|
||||
#define REAL_H
|
||||
typedef double MilanReal;
|
||||
typedef MPI_DOUBLE MilanMpiReal;
|
||||
inline MilanReal MilanAbs(MilanReal value)
|
||||
{
|
||||
return fabs(value);
|
||||
}
|
||||
#endif
|
||||
|
||||
//Regular float and absolute value computation:
|
||||
#ifndef FLOAT_H
|
||||
#define FLOAT_H
|
||||
typedef float MilanFloat;
|
||||
typedef MPI_FLOAT MilanMpiFloat;
|
||||
inline MilanFloat MilanAbsFloat(MilanFloat value)
|
||||
{
|
||||
return fabs(value);
|
||||
}
|
||||
#endif
|
||||
// Regular float and absolute value computation:
|
||||
#ifndef FLOAT_H
|
||||
#define FLOAT_H
|
||||
typedef float MilanFloat;
|
||||
typedef MPI_FLOAT MilanMpiFloat;
|
||||
inline MilanFloat MilanAbsFloat(MilanFloat value)
|
||||
{
|
||||
return fabs(value);
|
||||
}
|
||||
#endif
|
||||
|
||||
//// Define the limits:
|
||||
#ifndef LIMITS_H
|
||||
#define LIMITS_H
|
||||
//Integer Maximum and Minimum:
|
||||
// #define MilanIntMax INT_MAX
|
||||
// #define MilanIntMin INT_MIN
|
||||
#define MilanIntMax INT32_MAX
|
||||
#define MilanIntMin INT32_MIN
|
||||
//// Define the limits:
|
||||
#ifndef LIMITS_H
|
||||
#define LIMITS_H
|
||||
// Integer Maximum and Minimum:
|
||||
// #define MilanIntMax INT_MAX
|
||||
// #define MilanIntMin INT_MIN
|
||||
#define MilanIntMax INT32_MAX
|
||||
#define MilanIntMin INT32_MIN
|
||||
|
||||
#ifdef BIT64
|
||||
#define MilanLongIntMax INT64_MAX
|
||||
#define MilanLongIntMin -INT64_MAX
|
||||
#else
|
||||
#define MilanLongIntMax INT32_MAX
|
||||
#define MilanLongIntMin -INT32_MAX
|
||||
#endif
|
||||
#ifdef BIT64
|
||||
#define MilanLongIntMax INT64_MAX
|
||||
#define MilanLongIntMin -INT64_MAX
|
||||
#else
|
||||
#define MilanLongIntMax INT32_MAX
|
||||
#define MilanLongIntMin -INT32_MAX
|
||||
#endif
|
||||
|
||||
#endif
|
||||
#endif
|
||||
|
||||
// +INFINITY
|
||||
const double PLUS_INFINITY = numeric_limits<int>::infinity();
|
||||
const double MINUS_INFINITY = -PLUS_INFINITY;
|
||||
//#define MilanRealMax LDBL_MAX
|
||||
#define MilanRealMax PLUS_INFINITY
|
||||
#define MilanRealMin MINUS_INFINITY
|
||||
//#define MilanRealMax LDBL_MAX
|
||||
#define MilanRealMax PLUS_INFINITY
|
||||
#define MilanRealMin MINUS_INFINITY
|
||||
#endif
|
||||
|
||||
//Function of find the owner of a ghost vertex using binary search:
|
||||
inline MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
|
||||
MilanInt myRank, MilanInt numProcs);
|
||||
/* These functions are only used in the experimental OMP implementation, if that
|
||||
is disabled there is no reason to actually compile or reference them. */
|
||||
|
||||
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC
|
||||
(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanReal* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card );
|
||||
// Function of find the owner of a ghost vertex using binary search:
|
||||
MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
|
||||
MilanInt myRank, MilanInt numProcs);
|
||||
|
||||
MilanLongInt firstComputeCandidateMateD(MilanLongInt adj1,
|
||||
MilanLongInt adj2,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanReal *edgeLocWeight);
|
||||
|
||||
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC
|
||||
(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanFloat* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card );
|
||||
|
||||
void queuesTransfer(vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner);
|
||||
|
||||
bool isAlreadyMatched(MilanLongInt node,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
|
||||
|
||||
MilanLongInt computeCandidateMateD(MilanLongInt adj1,
|
||||
MilanLongInt adj2,
|
||||
MilanReal *edgeLocWeight,
|
||||
MilanLongInt k,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
|
||||
|
||||
void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt StartIndex, MilanLongInt EndIndex,
|
||||
MilanLongInt *numGhostEdgesPtr,
|
||||
MilanLongInt *numGhostVerticesPtr,
|
||||
MilanLongInt *S,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verLocPtr,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
vector<MilanLongInt> &Counter,
|
||||
vector<MilanLongInt> &verGhostPtr,
|
||||
vector<MilanLongInt> &verGhostInd,
|
||||
vector<MilanLongInt> &tempCounter,
|
||||
vector<MilanLongInt> &GMate,
|
||||
vector<MilanLongInt> &Message,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
MilanLongInt *&candidateMate,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner);
|
||||
|
||||
void clean(MilanLongInt NLVer,
|
||||
MilanInt myRank,
|
||||
MilanLongInt MessageIndex,
|
||||
vector<MPI_Request> &SRequest,
|
||||
vector<MPI_Status> &SStatus,
|
||||
MilanInt BufferSize,
|
||||
MilanLongInt *Buffer,
|
||||
MilanLongInt msgActual,
|
||||
MilanLongInt *msgActualSent,
|
||||
MilanLongInt msgInd,
|
||||
MilanLongInt *msgIndSent,
|
||||
MilanLongInt NumMessagesBundled,
|
||||
MilanReal *msgPercent);
|
||||
|
||||
void PARALLEL_COMPUTE_CANDIDATE_MATE_BD(MilanLongInt NLVer,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanInt myRank,
|
||||
MilanReal *edgeLocWeight,
|
||||
MilanLongInt *candidateMate);
|
||||
|
||||
void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer,
|
||||
MilanLongInt *candidateMate,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *Mate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanReal *edgeLocWeight,
|
||||
MilanLongInt *myCardPtr,
|
||||
MilanLongInt *msgIndPtr,
|
||||
MilanLongInt *NumMessagesBundledPtr,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner);
|
||||
|
||||
void PROCESS_CROSS_EDGE(MilanLongInt *edge,
|
||||
MilanLongInt *SPtr);
|
||||
|
||||
void processMatchedVerticesD(
|
||||
MilanLongInt NLVer,
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCardPtr,
|
||||
MilanLongInt *msgIndPtr,
|
||||
MilanLongInt *NumMessagesBundledPtr,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
MilanLongInt *candidateMate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanReal *edgeLocWeight,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner);
|
||||
|
||||
void processMatchedVerticesAndSendMessagesD(
|
||||
MilanLongInt NLVer,
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCardPtr,
|
||||
MilanLongInt *msgIndPtr,
|
||||
MilanLongInt *NumMessagesBundledPtr,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
MilanLongInt *candidateMate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanReal *edgeLocWeight,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner,
|
||||
MPI_Comm comm,
|
||||
MilanLongInt *msgActual,
|
||||
vector<MilanLongInt> &Message);
|
||||
|
||||
void sendBundledMessages(MilanLongInt *numGhostEdgesPtr,
|
||||
MilanInt *BufferSizePtr,
|
||||
MilanLongInt *Buffer,
|
||||
vector<MilanLongInt> &PCumulative,
|
||||
vector<MilanLongInt> &PMessageBundle,
|
||||
vector<MilanLongInt> &PSizeInfoMessages,
|
||||
MilanLongInt *PCounter,
|
||||
MilanLongInt NumMessagesBundled,
|
||||
MilanLongInt *msgActualPtr,
|
||||
MilanLongInt *MessageIndexPtr,
|
||||
MilanInt numProcs,
|
||||
MilanInt myRank,
|
||||
MPI_Comm comm,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MPI_Request> &SRequest,
|
||||
vector<MPI_Status> &SStatus);
|
||||
|
||||
void processMessagesD(
|
||||
MilanLongInt NLVer,
|
||||
MilanLongInt *Mate,
|
||||
MilanLongInt *candidateMate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
vector<MilanLongInt> &GMate,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCardPtr,
|
||||
MilanLongInt *msgIndPtr,
|
||||
MilanLongInt *msgActualPtr,
|
||||
MilanReal *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt k,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanInt numProcs,
|
||||
MilanInt myRank,
|
||||
MPI_Comm comm,
|
||||
vector<MilanLongInt> &Message,
|
||||
MilanLongInt numGhostEdges,
|
||||
MilanLongInt u,
|
||||
MilanLongInt v,
|
||||
MilanLongInt *SPtr,
|
||||
vector<MilanLongInt> &U);
|
||||
|
||||
void extractUChunk(
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU);
|
||||
|
||||
void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanReal* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MilanInt icomm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card );
|
||||
MilanLongInt firstComputeCandidateMateS(MilanLongInt adj1,
|
||||
MilanLongInt adj2,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanFloat *edgeLocWeight);
|
||||
|
||||
void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd, MilanFloat* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MilanInt icomm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent, MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card );
|
||||
MilanLongInt computeCandidateMateS(MilanLongInt adj1,
|
||||
MilanLongInt adj2,
|
||||
MilanFloat *edgeLocWeight,
|
||||
MilanLongInt k,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap);
|
||||
|
||||
void PARALLEL_COMPUTE_CANDIDATE_MATE_BS(MilanLongInt NLVer,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanInt myRank,
|
||||
MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *candidateMate);
|
||||
|
||||
void PARALLEL_PROCESS_EXPOSED_VERTEX_BS(MilanLongInt NLVer,
|
||||
MilanLongInt *candidateMate,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *Mate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *myCardPtr,
|
||||
MilanLongInt *msgIndPtr,
|
||||
MilanLongInt *NumMessagesBundledPtr,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner);
|
||||
void processMatchedVerticesS(
|
||||
MilanLongInt NLVer,
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCardPtr,
|
||||
MilanLongInt *msgIndPtr,
|
||||
MilanLongInt *NumMessagesBundledPtr,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
MilanLongInt *candidateMate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanFloat *edgeLocWeight,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner);
|
||||
|
||||
void processMatchedVerticesAndSendMessagesS(
|
||||
MilanLongInt NLVer,
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCardPtr,
|
||||
MilanLongInt *msgIndPtr,
|
||||
MilanLongInt *NumMessagesBundledPtr,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
MilanLongInt *candidateMate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanFloat *edgeLocWeight,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner,
|
||||
MPI_Comm comm,
|
||||
MilanLongInt *msgActual,
|
||||
vector<MilanLongInt> &Message);
|
||||
|
||||
void processMessagesS(
|
||||
MilanLongInt NLVer,
|
||||
MilanLongInt *Mate,
|
||||
MilanLongInt *candidateMate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
vector<MilanLongInt> &GMate,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCardPtr,
|
||||
MilanLongInt *msgIndPtr,
|
||||
MilanLongInt *msgActualPtr,
|
||||
MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt k,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanInt numProcs,
|
||||
MilanInt myRank,
|
||||
MPI_Comm comm,
|
||||
vector<MilanLongInt> &Message,
|
||||
MilanLongInt numGhostEdges,
|
||||
MilanLongInt u,
|
||||
MilanLongInt v,
|
||||
MilanLongInt *SPtr,
|
||||
vector<MilanLongInt> &U);
|
||||
|
||||
|
||||
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
|
||||
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
|
||||
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
|
||||
|
||||
|
||||
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateCMP(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
|
||||
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
|
||||
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
|
||||
|
||||
|
||||
|
||||
void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
|
||||
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
|
||||
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
|
||||
|
||||
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
|
||||
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
|
||||
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
|
||||
|
||||
void dMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanReal *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MilanInt icomm,
|
||||
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
|
||||
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
|
||||
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
|
||||
|
||||
void sMatchBoxPC(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt *verLocPtr, MilanLongInt *verLocInd, MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MilanInt icomm,
|
||||
MilanLongInt *msgIndSent, MilanLongInt *msgActualSent, MilanReal *msgPercent,
|
||||
MilanReal *ph0_time, MilanReal *ph1_time, MilanReal *ph2_time,
|
||||
MilanLongInt *ph1_card, MilanLongInt *ph2_card);
|
||||
|
||||
#endif
|
||||
#ifdef __cplusplus
|
||||
|
||||
+10
-16
@@ -72,12 +72,6 @@
|
||||
|
||||
#ifdef SERIAL_MPI
|
||||
#else
|
||||
//MPI type map
|
||||
template<typename T> MPI_Datatype TypeMap();
|
||||
template<> inline MPI_Datatype TypeMap<int64_t>() { return MPI_LONG_LONG; }
|
||||
template<> inline MPI_Datatype TypeMap<int>() { return MPI_INT; }
|
||||
template<> inline MPI_Datatype TypeMap<double>() { return MPI_DOUBLE; }
|
||||
template<> inline MPI_Datatype TypeMap<float>() { return MPI_FLOAT; }
|
||||
|
||||
// DOUBLE PRECISION VERSION
|
||||
//WARNING: The vertex block on a given rank is contiguous
|
||||
@@ -1309,16 +1303,16 @@ void dalgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
|
||||
// SINGLE PRECISION VERSION
|
||||
|
||||
void salgoDistEdgeApproxDomEdgesLinearSearchMesgBndlSmallMateC(
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd,
|
||||
MilanFloat* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent,
|
||||
MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
|
||||
MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt* verLocPtr, MilanLongInt* verLocInd,
|
||||
MilanFloat* edgeLocWeight,
|
||||
MilanLongInt* verDistance,
|
||||
MilanLongInt* Mate,
|
||||
MilanInt myRank, MilanInt numProcs, MPI_Comm comm,
|
||||
MilanLongInt* msgIndSent, MilanLongInt* msgActualSent,
|
||||
MilanReal* msgPercent,
|
||||
MilanReal* ph0_time, MilanReal* ph1_time, MilanReal* ph2_time,
|
||||
MilanLongInt* ph1_card, MilanLongInt* ph2_card ) {
|
||||
#if !defined(SERIAL_MPI)
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout<<"\n("<<myRank<<")Within algoEdgeApproxDominatingEdgesLinearSearchMessageBundling()"; fflush(stdout);
|
||||
|
||||
+1043
File diff suppressed because it is too large
Load Diff
@@ -97,6 +97,8 @@ subroutine amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
integer(psb_lpk_) :: ntaggr
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
logical :: clean_zeros
|
||||
integer(psb_ipk_), save :: idx_map_bld=-1, idx_map_tprol=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
name='amg_c_dec_aggregator_tprol'
|
||||
call psb_erractionsave(err_act)
|
||||
@@ -108,6 +110,10 @@ subroutine amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_map_bld==-1)) &
|
||||
& idx_map_bld = psb_get_timer_idx("DEC_TPROL: map_bld")
|
||||
if ((do_timings).and.(idx_map_tprol==-1)) &
|
||||
& idx_map_tprol = psb_get_timer_idx("DEC_TPROL: map_tprol")
|
||||
|
||||
call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
|
||||
& amg_mult_ml_,is_legal_ml_cycle)
|
||||
@@ -121,10 +127,14 @@ subroutine amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
! The decoupled aggregator based on SOC measures ignores
|
||||
! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_map_bld)
|
||||
clean_zeros = ag%do_clean_zeros
|
||||
call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
|
||||
if (do_timings) call psb_toc(idx_map_bld)
|
||||
if (do_timings) call psb_tic(idx_map_tprol)
|
||||
|
||||
if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_map_tprol)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')
|
||||
|
||||
@@ -76,7 +76,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
|
||||
integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza
|
||||
logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
|
||||
|
||||
name='amg_ptap_bld'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
@@ -93,7 +93,11 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
|
||||
& idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_cpytrans1==-1)) &
|
||||
& idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
|
||||
if ((do_timings).and.(idx_cpytrans2==-1)) &
|
||||
& idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
|
||||
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
@@ -128,6 +132,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
! Ok first product done.
|
||||
|
||||
if (present(desc_ax)) then
|
||||
if (do_timings) call psb_tic(idx_cpytrans1)
|
||||
block
|
||||
call coo_prol%cp_to_coo(coo_restr,info)
|
||||
call coo_restr%set_ncols(desc_ac%get_local_cols())
|
||||
@@ -137,7 +142,7 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
call coo_restr%set_ncols(desc_ax%get_local_cols())
|
||||
end block
|
||||
call csr_restr%cp_from_coo(coo_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_cpytrans1)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
|
||||
goto 9999
|
||||
@@ -167,27 +172,28 @@ subroutine amg_c_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
|
||||
call coo_restr%transp()
|
||||
nzl = coo_restr%get_nzeros()
|
||||
nrl = desc_ac%get_local_rows()
|
||||
i=0
|
||||
nrl = desc_ac%get_local_rows()
|
||||
call coo_restr%fix(info)
|
||||
i=coo_restr%get_nzeros()
|
||||
!
|
||||
! Only keep local rows
|
||||
!
|
||||
do k=1, nzl
|
||||
if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
|
||||
i = i+1
|
||||
coo_restr%val(i) = coo_restr%val(k)
|
||||
coo_restr%ia(i) = coo_restr%ia(k)
|
||||
coo_restr%ja(i) = coo_restr%ja(k)
|
||||
search: do k=i,1,-1
|
||||
if (coo_restr%ia(k) <= nrl) then
|
||||
call coo_restr%set_nzeros(k)
|
||||
exit search
|
||||
end if
|
||||
end do
|
||||
call coo_restr%set_nzeros(i)
|
||||
call coo_restr%fix(info)
|
||||
end do search
|
||||
|
||||
nzl = coo_restr%get_nzeros()
|
||||
call coo_restr%set_nrows(desc_ac%get_local_rows())
|
||||
call coo_restr%set_ncols(desc_a%get_local_cols())
|
||||
if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
|
||||
if (do_timings) call psb_tic(idx_cpytrans2)
|
||||
|
||||
call csr_restr%cp_from_coo(coo_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_cpytrans2)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
|
||||
goto 9999
|
||||
|
||||
+219
-21
@@ -72,7 +72,9 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_c_inner_mod
|
||||
|
||||
#if defined(OPENMP)
|
||||
use omp_lib
|
||||
#endif
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
@@ -85,7 +87,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
|
||||
integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
|
||||
& ideg(:), idxs(:)
|
||||
integer(psb_lpk_), allocatable :: tmpaggr(:)
|
||||
complex(psb_spk_), allocatable :: val(:), diag(:)
|
||||
@@ -99,6 +101,9 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_) :: nrow, ncol, n_ne
|
||||
integer(psb_lpk_) :: nrglob
|
||||
character(len=20) :: name, ch_err
|
||||
integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
|
||||
integer(psb_ipk_), save :: idx_soc1_p0=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
|
||||
info=psb_success_
|
||||
name = 'amg_soc1_map_bld'
|
||||
@@ -114,6 +119,14 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
nrglob = desc_a%get_global_rows()
|
||||
if ((do_timings).and.(idx_soc1_p0==-1)) &
|
||||
& idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
|
||||
if ((do_timings).and.(idx_soc1_p1==-1)) &
|
||||
& idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
|
||||
if ((do_timings).and.(idx_soc1_p2==-1)) &
|
||||
& idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
|
||||
if ((do_timings).and.(idx_soc1_p3==-1)) &
|
||||
& idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
|
||||
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -133,41 +146,205 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p0)
|
||||
call a%cp_to(acsr)
|
||||
if (do_timings) call psb_toc(idx_soc1_p0)
|
||||
if (clean_zeros) call acsr%clean_zeros(info)
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
!$omp parallel do private(i) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
idxs(i) = i
|
||||
idxs(i) = i
|
||||
end do
|
||||
else
|
||||
!$omp end parallel do
|
||||
else
|
||||
!$omp parallel do private(i) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
ideg(i) = acsr%irp(i+1) - acsr%irp(i)
|
||||
end do
|
||||
!$omp end parallel do
|
||||
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p1)
|
||||
|
||||
!
|
||||
! Phase one: Start with disjoint groups.
|
||||
!
|
||||
naggr = 0
|
||||
icnt = 0
|
||||
#if defined(OPENMP)
|
||||
block
|
||||
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
|
||||
integer(psb_ipk_) :: myth,nths, kk
|
||||
! The parallelization makes use of a locaggr(:) array; each thread
|
||||
! keeps its own version of naggr, and when the loop ends, a prefix is applied
|
||||
! to locnaggr to determine:
|
||||
! 1. The total number of aggregaters NAGGR;
|
||||
! 2. How much should each thread shift its own aggregates
|
||||
! Part 2 requires to keep track of which thread defined each entry
|
||||
! of ilaggr(), so that each entry can be adjusted correctly: even
|
||||
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
|
||||
! been set because it is strongly connected to an entry J belonging to a
|
||||
! different thread.
|
||||
|
||||
!$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
|
||||
!$omp private(icol,val,myth,kk)
|
||||
block
|
||||
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg, ip, rsz
|
||||
integer(psb_lpk_) :: itmp
|
||||
!$omp master
|
||||
nths = omp_get_num_threads()
|
||||
allocate(bnds(0:nths),locnaggr(0:nths+1))
|
||||
locnaggr(:) = 0
|
||||
bnds(0) = 1
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
myth = omp_get_thread_num()
|
||||
rsz = nr/nths
|
||||
if (myth < mod(nr,nths)) rsz = rsz + 1
|
||||
bnds(myth+1) = rsz
|
||||
!$omp barrier
|
||||
!$omp master
|
||||
do i=1,nths
|
||||
bnds(i) = bnds(i) + bnds(i-1)
|
||||
end do
|
||||
info = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
|
||||
!$omp do schedule(static) private(disjoint)
|
||||
do kk=0, nths-1
|
||||
step1: do ii=bnds(kk), bnds(kk+1)-1
|
||||
i = idxs(ii)
|
||||
if (info /= 0) cycle step1
|
||||
if ((i<1).or.(i>nr)) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if ((nz<0).or.(nz>size(icol))) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
|
||||
!
|
||||
! Build the set of all strongly coupled nodes
|
||||
!
|
||||
ip = 0
|
||||
do k=1, nz
|
||||
j = icol(k)
|
||||
! If any of the neighbours is already assigned,
|
||||
! we will not reset.
|
||||
if (j>nr) cycle step1
|
||||
if (ilaggr(j) > 0) cycle step1
|
||||
if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
|
||||
ip = ip + 1
|
||||
icol(ip) = icol(k)
|
||||
end if
|
||||
enddo
|
||||
|
||||
!
|
||||
! If the whole strongly coupled neighborhood of I is
|
||||
! as yet unconnected, turn it into the next aggregate.
|
||||
! Same if ip==0 (in which case, neighborhood only
|
||||
! contains I even if it does not look like it from matrix)
|
||||
! The fact that DISJOINT is private and not under lock
|
||||
! generates a certain un-repeatability, in that between
|
||||
! computing DISJOINT and assigning, another thread might
|
||||
! alter the values of ILAGGR.
|
||||
! However, a certain unrepeatability is already present
|
||||
! because the sequence of aggregates is computed with a
|
||||
! different order than in serial mode.
|
||||
! In any case, even if the enteries of ILAGGR may be
|
||||
! overwritten, the important thing is that each entry is
|
||||
! consistent and they generate a correct aggregation map.
|
||||
!
|
||||
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
|
||||
if (disjoint) then
|
||||
locnaggr(kk) = locnaggr(kk) + 1
|
||||
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
|
||||
itmp = itmp*nths+kk
|
||||
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
|
||||
!$omp atomic update
|
||||
info = max(12345678,info)
|
||||
!$omp end atomic
|
||||
cycle step1
|
||||
end if
|
||||
!$omp atomic write
|
||||
ilaggr(i) = itmp
|
||||
!$omp end atomic
|
||||
do k=1, ip
|
||||
!$omp atomic write
|
||||
ilaggr(icol(k)) = itmp
|
||||
!$omp end atomic
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
enddo step1
|
||||
end do
|
||||
!$omp end do
|
||||
|
||||
!$omp master
|
||||
naggr = sum(locnaggr(0:nths-1))
|
||||
do i=1,nths
|
||||
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
|
||||
end do
|
||||
do i=nths+1,1,-1
|
||||
locnaggr(i) = locnaggr(i-1)
|
||||
end do
|
||||
locnaggr(0) = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
!$omp do schedule(static)
|
||||
do kk=0, nths-1
|
||||
do ii=bnds(kk), bnds(kk+1)-1
|
||||
if (ilaggr(ii) > 0) then
|
||||
kp = mod(ilaggr(ii),nths)
|
||||
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end do
|
||||
end block
|
||||
!$omp end parallel
|
||||
end block
|
||||
if (info /= 0) then
|
||||
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
#else
|
||||
step1: do ii=1, nr
|
||||
if (info /= 0) cycle
|
||||
i = idxs(ii)
|
||||
if ((i<1).or.(i>nr)) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if ((nz<0).or.(nz>size(icol))) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
@@ -176,7 +353,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
!
|
||||
! Build the set of all strongly coupled nodes
|
||||
!
|
||||
ip = 0
|
||||
ip = 0
|
||||
do k=1, nz
|
||||
j = icol(k)
|
||||
if ((1<=j).and.(j<=nr)) then
|
||||
@@ -194,8 +371,7 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! contains I even if it does not look like it from matrix)
|
||||
!
|
||||
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
|
||||
if (disjoint) then
|
||||
icnt = icnt + 1
|
||||
if (disjoint) then
|
||||
naggr = naggr + 1
|
||||
do k=1, ip
|
||||
ilaggr(icol(k)) = naggr
|
||||
@@ -204,16 +380,22 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
endif
|
||||
enddo step1
|
||||
|
||||
#endif
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1:',count(ilaggr == -(nr+1))
|
||||
& ' Check 1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc1_p1)
|
||||
if (do_timings) call psb_tic(idx_soc1_p2)
|
||||
!
|
||||
! Phase two: join the neighbours
|
||||
!
|
||||
!$omp workshare
|
||||
tmpaggr = ilaggr
|
||||
!$omp end workshare
|
||||
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
|
||||
step2: do ii=1,nr
|
||||
i = idxs(ii)
|
||||
|
||||
@@ -244,8 +426,15 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
end if
|
||||
end do step2
|
||||
!$omp end parallel do
|
||||
if (do_timings) call psb_toc(idx_soc1_p2)
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p3)
|
||||
!
|
||||
! Phase three: sweep over leftovers, if any
|
||||
!
|
||||
@@ -274,7 +463,6 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
enddo
|
||||
if (ip > 0) then
|
||||
icnt = icnt + 1
|
||||
naggr = naggr + 1
|
||||
ilaggr(i) = naggr
|
||||
do k=1, ip
|
||||
@@ -292,7 +480,10 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end do step3
|
||||
|
||||
! Any leftovers?
|
||||
!$omp parallel do schedule(static) shared(ilaggr,info)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip)
|
||||
do i=1, nr
|
||||
if (info /= 0) cycle
|
||||
if (ilaggr(i) < 0) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if (nz == 1) then
|
||||
@@ -303,15 +494,18 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! other processes.
|
||||
ilaggr(i) = -(nrglob+nr)
|
||||
else
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
|
||||
goto 9999
|
||||
cycle
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
if (info /= 0) goto 9999
|
||||
if (do_timings) call psb_toc(idx_soc1_p3)
|
||||
if (naggr > ncol) then
|
||||
!write(0,*) name,'Error : naggr > ncol',naggr,ncol
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
|
||||
goto 9999
|
||||
@@ -336,9 +530,13 @@ subroutine amg_c_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nlaggr(:) = 0
|
||||
nlaggr(me+1) = naggr
|
||||
call psb_sum(ctxt,nlaggr(1:np))
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
call acsr%free()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+206
-16
@@ -68,9 +68,12 @@
|
||||
!
|
||||
subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_c_inner_mod
|
||||
#if defined(OPENMP)
|
||||
use omp_lib
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
|
||||
@@ -99,6 +102,9 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: nrow, ncol, n_ne
|
||||
character(len=20) :: name, ch_err
|
||||
integer(psb_ipk_), save :: idx_soc2_p1=-1, idx_soc2_p2=-1, idx_soc2_p3=-1
|
||||
integer(psb_ipk_), save :: idx_soc2_p0=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
|
||||
info=psb_success_
|
||||
name = 'amg_soc2_map_bld'
|
||||
@@ -114,6 +120,14 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
nrglob = desc_a%get_global_rows()
|
||||
if ((do_timings).and.(idx_soc2_p0==-1)) &
|
||||
& idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
|
||||
if ((do_timings).and.(idx_soc2_p1==-1)) &
|
||||
& idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
|
||||
if ((do_timings).and.(idx_soc2_p2==-1)) &
|
||||
& idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
|
||||
if ((do_timings).and.(idx_soc2_p3==-1)) &
|
||||
& idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
|
||||
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -125,6 +139,7 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc2_p0)
|
||||
diag = a%get_diag(info)
|
||||
if(info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
@@ -137,55 +152,218 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
!
|
||||
call a%cp_to(muij)
|
||||
if (clean_zeros) call muij%clean_zeros(info)
|
||||
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
|
||||
do i=1, nr
|
||||
do k=muij%irp(i),muij%irp(i+1)-1
|
||||
j = muij%ja(k)
|
||||
if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
|
||||
end do
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
!
|
||||
! Compute the 1-neigbour; mark strong links with +1, weak links with -1
|
||||
!
|
||||
call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
|
||||
ip = 0
|
||||
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
|
||||
do i=1, nr
|
||||
do k=muij%irp(i),muij%irp(i+1)-1
|
||||
j = muij%ja(k)
|
||||
s_neigh_coo%ia(k) = i
|
||||
s_neigh_coo%ja(k) = j
|
||||
if (j<=nr) then
|
||||
ip = ip + 1
|
||||
s_neigh_coo%ia(ip) = i
|
||||
s_neigh_coo%ja(ip) = j
|
||||
if (real(muij%val(k)) >= theta) then
|
||||
s_neigh_coo%val(ip) = sone
|
||||
s_neigh_coo%val(k) = sone
|
||||
else
|
||||
s_neigh_coo%val(ip) = -sone
|
||||
s_neigh_coo%val(k) = -sone
|
||||
end if
|
||||
else
|
||||
s_neigh_coo%val(k) = -sone
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end parallel do
|
||||
!write(*,*) 'S_NEIGH: ',nr,ip
|
||||
call s_neigh_coo%set_nzeros(ip)
|
||||
call s_neigh_coo%set_nzeros(muij%get_nzeros())
|
||||
call s_neigh%mv_from_coo(s_neigh_coo,info)
|
||||
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
|
||||
!$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
idxs(i) = i
|
||||
end do
|
||||
!$omp end parallel do
|
||||
else
|
||||
!$omp parallel do private(i) shared(ilaggr,idxs,muij) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
ideg(i) = muij%irp(i+1) - muij%irp(i)
|
||||
end do
|
||||
!$omp end parallel do
|
||||
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc2_p0)
|
||||
if (do_timings) call psb_tic(idx_soc2_p1)
|
||||
|
||||
!
|
||||
! Phase one: Start with disjoint groups.
|
||||
!
|
||||
naggr = 0
|
||||
#if defined(OPENMP)
|
||||
block
|
||||
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
|
||||
integer(psb_ipk_) :: myth,nths, kk
|
||||
! The parallelization makes use of a locaggr(:) array; each thread
|
||||
! keeps its own version of naggr, and when the loop ends, a prefix is applied
|
||||
! to locnaggr to determine:
|
||||
! 1. The total number of aggregaters NAGGR;
|
||||
! 2. How much should each thread shift its own aggregates
|
||||
! Part 2 requires to keep track of which thread defined each entry
|
||||
! of ilaggr(), so that each entry can be adjusted correctly: even
|
||||
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
|
||||
! been set because it is strongly connected to an entry J belonging to a
|
||||
! different thread.
|
||||
|
||||
!$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
|
||||
!$omp private(icol,val,myth,kk)
|
||||
block
|
||||
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
|
||||
integer(psb_lpk_) :: itmp
|
||||
!$omp master
|
||||
nths = omp_get_num_threads()
|
||||
allocate(bnds(0:nths),locnaggr(0:nths+1))
|
||||
locnaggr(:) = 0
|
||||
bnds(0) = 1
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
myth = omp_get_thread_num()
|
||||
rsz = nr/nths
|
||||
if (myth < mod(nr,nths)) rsz = rsz + 1
|
||||
bnds(myth+1) = rsz
|
||||
!$omp barrier
|
||||
!$omp master
|
||||
do i=1,nths
|
||||
bnds(i) = bnds(i) + bnds(i-1)
|
||||
end do
|
||||
info = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
|
||||
!$omp do schedule(static) private(disjoint)
|
||||
do kk=0, nths-1
|
||||
step1: do ii=bnds(kk), bnds(kk+1)-1
|
||||
i = idxs(ii)
|
||||
if (info /= 0) then
|
||||
write(0,*) ' Step1:',kk,ii,i,info
|
||||
cycle step1
|
||||
end if
|
||||
if ((i<1).or.(i>nr)) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
!
|
||||
! Get the 1-neighbourhood of I
|
||||
!
|
||||
ip1 = s_neigh%irp(i)
|
||||
nz = s_neigh%irp(i+1)-ip1
|
||||
!
|
||||
! If the neighbourhood only contains I, skip it
|
||||
!
|
||||
if (nz ==0) then
|
||||
ilaggr(i) = 0
|
||||
cycle step1
|
||||
end if
|
||||
if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
|
||||
ilaggr(i) = 0
|
||||
cycle step1
|
||||
end if
|
||||
|
||||
nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
|
||||
icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
|
||||
disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1))
|
||||
|
||||
!
|
||||
! If the whole strongly coupled neighborhood of I is
|
||||
! as yet unconnected, turn it into the next aggregate.
|
||||
! Same if ip==0 (in which case, neighborhood only
|
||||
! contains I even if it does not look like it from matrix)
|
||||
! The fact that DISJOINT is private and not under lock
|
||||
! generates a certain un-repeatability, in that between
|
||||
! computing DISJOINT and assigning, another thread might
|
||||
! alter the values of ILAGGR.
|
||||
! However, a certain unrepeatability is already present
|
||||
! because the sequence of aggregates is computed with a
|
||||
! different order than in serial mode.
|
||||
! In any case, even if the enteries of ILAGGR may be
|
||||
! overwritten, the important thing is that each entry is
|
||||
! consistent and they generate a correct aggregation map.
|
||||
!
|
||||
if (disjoint) then
|
||||
locnaggr(kk) = locnaggr(kk) + 1
|
||||
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
|
||||
itmp = itmp*nths+kk
|
||||
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
|
||||
!$omp atomic update
|
||||
info = max(12345678,info)
|
||||
!$omp end atomic
|
||||
cycle step1
|
||||
end if
|
||||
!$omp atomic write
|
||||
ilaggr(i) = itmp
|
||||
!$omp end atomic
|
||||
do k=1, nzcnt
|
||||
!$omp atomic write
|
||||
ilaggr(icol(k)) = itmp
|
||||
!$omp end atomic
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
enddo step1
|
||||
end do
|
||||
!$omp end do
|
||||
|
||||
!$omp master
|
||||
naggr = sum(locnaggr(0:nths-1))
|
||||
do i=1,nths
|
||||
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
|
||||
end do
|
||||
do i=nths+1,1,-1
|
||||
locnaggr(i) = locnaggr(i-1)
|
||||
end do
|
||||
locnaggr(0) = 0
|
||||
!write(0,*) 'LNAG ',locnaggr(nths+1)
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
!$omp do schedule(static)
|
||||
do kk=0, nths-1
|
||||
do ii=bnds(kk), bnds(kk+1)-1
|
||||
if (ilaggr(ii) > 0) then
|
||||
kp = mod(ilaggr(ii),nths)
|
||||
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end do
|
||||
end block
|
||||
!$omp end parallel
|
||||
end block
|
||||
if (info /= 0) then
|
||||
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
#else
|
||||
icnt = 0
|
||||
step1: do ii=1, nr
|
||||
i = idxs(ii)
|
||||
@@ -224,16 +402,21 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
endif
|
||||
enddo step1
|
||||
|
||||
#endif
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1:',count(ilaggr == -(nr+1))
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc2_p1)
|
||||
if (do_timings) call psb_tic(idx_soc2_p2)
|
||||
!
|
||||
! Phase two: join the neighbours
|
||||
!
|
||||
!$omp workshare
|
||||
tmpaggr = ilaggr
|
||||
!$omp end workshare
|
||||
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
|
||||
step2: do ii=1,nr
|
||||
i = idxs(ii)
|
||||
|
||||
@@ -259,8 +442,9 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
end if
|
||||
end do step2
|
||||
|
||||
|
||||
!$omp end parallel do
|
||||
if (do_timings) call psb_toc(idx_soc2_p2)
|
||||
if (do_timings) call psb_tic(idx_soc2_p3)
|
||||
!
|
||||
! Phase three: sweep over leftovers, if any
|
||||
!
|
||||
@@ -294,6 +478,8 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end do step3
|
||||
|
||||
! Any leftovers?
|
||||
!$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)&
|
||||
!$omp private(ii,i,j,k)
|
||||
do i=1, nr
|
||||
if (ilaggr(i) <= 0) then
|
||||
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
|
||||
@@ -305,13 +491,17 @@ subroutine amg_c_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! other processes.
|
||||
ilaggr(i) = -(nrglob+nr)
|
||||
else
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
|
||||
goto 9999
|
||||
cycle
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
if (info /= 0) goto 9999
|
||||
if (do_timings) call psb_toc(idx_soc2_p3)
|
||||
if (naggr > ncol) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
|
||||
@@ -140,6 +140,9 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
real(psb_spk_) :: anorm, omega, tmp, dg, theta
|
||||
logical, parameter :: debug_new=.false.
|
||||
character(len=80) :: filename
|
||||
logical, parameter :: do_timings=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1
|
||||
integer(psb_ipk_), save :: idx_phase3=-1, idx_cdasb=-1, idx_ptap=-1
|
||||
|
||||
name='amg_aggrmat_smth_bld'
|
||||
info=psb_success_
|
||||
@@ -153,6 +156,23 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
ctxt = desc_a%get_context()
|
||||
|
||||
call psb_info(ctxt, me, np)
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("DEC_SMTH_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_phase1==-1)) &
|
||||
& idx_phase1 = psb_get_timer_idx("DEC_SMTH_BLD: phase1 ")
|
||||
if ((do_timings).and.(idx_phase2==-1)) &
|
||||
& idx_phase2 = psb_get_timer_idx("DEC_SMTH_BLD: phase2 ")
|
||||
if ((do_timings).and.(idx_phase3==-1)) &
|
||||
& idx_phase3 = psb_get_timer_idx("DEC_SMTH_BLD: phase3 ")
|
||||
if ((do_timings).and.(idx_gtrans==-1)) &
|
||||
& idx_gtrans = psb_get_timer_idx("DEC_SMTH_BLD: gtrans ")
|
||||
if ((do_timings).and.(idx_refine==-1)) &
|
||||
& idx_refine = psb_get_timer_idx("DEC_SMTH_BLD: refine ")
|
||||
if ((do_timings).and.(idx_cdasb==-1)) &
|
||||
& idx_cdasb = psb_get_timer_idx("DEC_SMTH_BLD: cdasb ")
|
||||
if ((do_timings).and.(idx_ptap==-1)) &
|
||||
& idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld ")
|
||||
|
||||
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
@@ -171,6 +191,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
! naggr: number of local aggregates
|
||||
! nrow: local rows.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_phase1)
|
||||
|
||||
! Get the diagonal D
|
||||
adiag = a%get_diag(info)
|
||||
@@ -196,7 +217,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
!
|
||||
! Build the filtered matrix Af from A
|
||||
!
|
||||
|
||||
!$OMP parallel do private(i,j,tmp,jd) schedule(static)
|
||||
do i=1, nrow
|
||||
tmp = czero
|
||||
jd = -1
|
||||
@@ -214,11 +235,13 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
acsrf%val(jd)=acsrf%val(jd)-tmp
|
||||
end if
|
||||
enddo
|
||||
!$OMP end parallel do
|
||||
! Take out zeroed terms
|
||||
call acsrf%clean_zeros(info)
|
||||
end if
|
||||
|
||||
|
||||
!$OMP parallel do private(i) schedule(static)
|
||||
do i=1,size(adiag)
|
||||
if (adiag(i) /= czero) then
|
||||
adiag(i) = cone / adiag(i)
|
||||
@@ -226,7 +249,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
adiag(i) = cone
|
||||
end if
|
||||
end do
|
||||
|
||||
!$OMP end parallel do
|
||||
if (parms%aggr_omega_alg == amg_eig_est_) then
|
||||
|
||||
if (parms%aggr_eig == amg_max_norm_) then
|
||||
@@ -252,8 +275,9 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
|
||||
goto 9999
|
||||
end if
|
||||
if (do_timings) call psb_toc(idx_phase1)
|
||||
|
||||
|
||||
if (do_timings) call psb_tic(idx_phase2)
|
||||
call acsrf%scal(adiag,info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
@@ -267,6 +291,8 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
|
||||
call psb_cdasb(desc_ac,info)
|
||||
call psb_cd_reinit(desc_ac,info)
|
||||
if (do_timings) call psb_toc(idx_phase2)
|
||||
if (do_timings) call psb_tic(idx_phase3)
|
||||
!
|
||||
! Build the smoothed prolongator using either A or Af
|
||||
! acsr1 = (I-w*D*A) Prol acsr1 = (I-w*D*Af) Prol
|
||||
@@ -279,8 +305,8 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (do_timings) call psb_toc(idx_phase3)
|
||||
if (do_timings) call psb_tic(idx_ptap)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done SPSPMM 1'
|
||||
@@ -292,7 +318,7 @@ subroutine amg_caggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
|
||||
call op_prol%mv_from(coo_prol)
|
||||
call op_restr%mv_from(coo_restr)
|
||||
|
||||
if (do_timings) call psb_toc(idx_ptap)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done smooth_aggregate '
|
||||
|
||||
@@ -97,6 +97,8 @@ subroutine amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
integer(psb_lpk_) :: ntaggr
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
logical :: clean_zeros
|
||||
integer(psb_ipk_), save :: idx_map_bld=-1, idx_map_tprol=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
name='amg_d_dec_aggregator_tprol'
|
||||
call psb_erractionsave(err_act)
|
||||
@@ -108,6 +110,10 @@ subroutine amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_map_bld==-1)) &
|
||||
& idx_map_bld = psb_get_timer_idx("DEC_TPROL: map_bld")
|
||||
if ((do_timings).and.(idx_map_tprol==-1)) &
|
||||
& idx_map_tprol = psb_get_timer_idx("DEC_TPROL: map_tprol")
|
||||
|
||||
call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
|
||||
& amg_mult_ml_,is_legal_ml_cycle)
|
||||
@@ -121,10 +127,14 @@ subroutine amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
! The decoupled aggregator based on SOC measures ignores
|
||||
! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_map_bld)
|
||||
clean_zeros = ag%do_clean_zeros
|
||||
call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
|
||||
if (do_timings) call psb_toc(idx_map_bld)
|
||||
if (do_timings) call psb_tic(idx_map_tprol)
|
||||
|
||||
if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_map_tprol)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')
|
||||
|
||||
@@ -76,7 +76,7 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
|
||||
integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza
|
||||
logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
|
||||
|
||||
name='amg_ptap_bld'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
@@ -93,7 +93,11 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
|
||||
& idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_cpytrans1==-1)) &
|
||||
& idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
|
||||
if ((do_timings).and.(idx_cpytrans2==-1)) &
|
||||
& idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
|
||||
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
@@ -128,6 +132,7 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
! Ok first product done.
|
||||
|
||||
if (present(desc_ax)) then
|
||||
if (do_timings) call psb_tic(idx_cpytrans1)
|
||||
block
|
||||
call coo_prol%cp_to_coo(coo_restr,info)
|
||||
call coo_restr%set_ncols(desc_ac%get_local_cols())
|
||||
@@ -137,7 +142,7 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
call coo_restr%set_ncols(desc_ax%get_local_cols())
|
||||
end block
|
||||
call csr_restr%cp_from_coo(coo_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_cpytrans1)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
|
||||
goto 9999
|
||||
@@ -167,27 +172,28 @@ subroutine amg_d_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
|
||||
call coo_restr%transp()
|
||||
nzl = coo_restr%get_nzeros()
|
||||
nrl = desc_ac%get_local_rows()
|
||||
i=0
|
||||
nrl = desc_ac%get_local_rows()
|
||||
call coo_restr%fix(info)
|
||||
i=coo_restr%get_nzeros()
|
||||
!
|
||||
! Only keep local rows
|
||||
!
|
||||
do k=1, nzl
|
||||
if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
|
||||
i = i+1
|
||||
coo_restr%val(i) = coo_restr%val(k)
|
||||
coo_restr%ia(i) = coo_restr%ia(k)
|
||||
coo_restr%ja(i) = coo_restr%ja(k)
|
||||
search: do k=i,1,-1
|
||||
if (coo_restr%ia(k) <= nrl) then
|
||||
call coo_restr%set_nzeros(k)
|
||||
exit search
|
||||
end if
|
||||
end do
|
||||
call coo_restr%set_nzeros(i)
|
||||
call coo_restr%fix(info)
|
||||
end do search
|
||||
|
||||
nzl = coo_restr%get_nzeros()
|
||||
call coo_restr%set_nrows(desc_ac%get_local_rows())
|
||||
call coo_restr%set_ncols(desc_a%get_local_cols())
|
||||
if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
|
||||
if (do_timings) call psb_tic(idx_cpytrans2)
|
||||
|
||||
call csr_restr%cp_from_coo(coo_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_cpytrans2)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
|
||||
goto 9999
|
||||
|
||||
+219
-21
@@ -72,7 +72,9 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_d_inner_mod
|
||||
|
||||
#if defined(OPENMP)
|
||||
use omp_lib
|
||||
#endif
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
@@ -85,7 +87,7 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
|
||||
integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
|
||||
& ideg(:), idxs(:)
|
||||
integer(psb_lpk_), allocatable :: tmpaggr(:)
|
||||
real(psb_dpk_), allocatable :: val(:), diag(:)
|
||||
@@ -99,6 +101,9 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_) :: nrow, ncol, n_ne
|
||||
integer(psb_lpk_) :: nrglob
|
||||
character(len=20) :: name, ch_err
|
||||
integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
|
||||
integer(psb_ipk_), save :: idx_soc1_p0=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
|
||||
info=psb_success_
|
||||
name = 'amg_soc1_map_bld'
|
||||
@@ -114,6 +119,14 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
nrglob = desc_a%get_global_rows()
|
||||
if ((do_timings).and.(idx_soc1_p0==-1)) &
|
||||
& idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
|
||||
if ((do_timings).and.(idx_soc1_p1==-1)) &
|
||||
& idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
|
||||
if ((do_timings).and.(idx_soc1_p2==-1)) &
|
||||
& idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
|
||||
if ((do_timings).and.(idx_soc1_p3==-1)) &
|
||||
& idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
|
||||
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -133,41 +146,205 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p0)
|
||||
call a%cp_to(acsr)
|
||||
if (do_timings) call psb_toc(idx_soc1_p0)
|
||||
if (clean_zeros) call acsr%clean_zeros(info)
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
!$omp parallel do private(i) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
idxs(i) = i
|
||||
idxs(i) = i
|
||||
end do
|
||||
else
|
||||
!$omp end parallel do
|
||||
else
|
||||
!$omp parallel do private(i) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
ideg(i) = acsr%irp(i+1) - acsr%irp(i)
|
||||
end do
|
||||
!$omp end parallel do
|
||||
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p1)
|
||||
|
||||
!
|
||||
! Phase one: Start with disjoint groups.
|
||||
!
|
||||
naggr = 0
|
||||
icnt = 0
|
||||
#if defined(OPENMP)
|
||||
block
|
||||
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
|
||||
integer(psb_ipk_) :: myth,nths, kk
|
||||
! The parallelization makes use of a locaggr(:) array; each thread
|
||||
! keeps its own version of naggr, and when the loop ends, a prefix is applied
|
||||
! to locnaggr to determine:
|
||||
! 1. The total number of aggregaters NAGGR;
|
||||
! 2. How much should each thread shift its own aggregates
|
||||
! Part 2 requires to keep track of which thread defined each entry
|
||||
! of ilaggr(), so that each entry can be adjusted correctly: even
|
||||
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
|
||||
! been set because it is strongly connected to an entry J belonging to a
|
||||
! different thread.
|
||||
|
||||
!$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
|
||||
!$omp private(icol,val,myth,kk)
|
||||
block
|
||||
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg, ip, rsz
|
||||
integer(psb_lpk_) :: itmp
|
||||
!$omp master
|
||||
nths = omp_get_num_threads()
|
||||
allocate(bnds(0:nths),locnaggr(0:nths+1))
|
||||
locnaggr(:) = 0
|
||||
bnds(0) = 1
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
myth = omp_get_thread_num()
|
||||
rsz = nr/nths
|
||||
if (myth < mod(nr,nths)) rsz = rsz + 1
|
||||
bnds(myth+1) = rsz
|
||||
!$omp barrier
|
||||
!$omp master
|
||||
do i=1,nths
|
||||
bnds(i) = bnds(i) + bnds(i-1)
|
||||
end do
|
||||
info = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
|
||||
!$omp do schedule(static) private(disjoint)
|
||||
do kk=0, nths-1
|
||||
step1: do ii=bnds(kk), bnds(kk+1)-1
|
||||
i = idxs(ii)
|
||||
if (info /= 0) cycle step1
|
||||
if ((i<1).or.(i>nr)) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if ((nz<0).or.(nz>size(icol))) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
|
||||
!
|
||||
! Build the set of all strongly coupled nodes
|
||||
!
|
||||
ip = 0
|
||||
do k=1, nz
|
||||
j = icol(k)
|
||||
! If any of the neighbours is already assigned,
|
||||
! we will not reset.
|
||||
if (j>nr) cycle step1
|
||||
if (ilaggr(j) > 0) cycle step1
|
||||
if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
|
||||
ip = ip + 1
|
||||
icol(ip) = icol(k)
|
||||
end if
|
||||
enddo
|
||||
|
||||
!
|
||||
! If the whole strongly coupled neighborhood of I is
|
||||
! as yet unconnected, turn it into the next aggregate.
|
||||
! Same if ip==0 (in which case, neighborhood only
|
||||
! contains I even if it does not look like it from matrix)
|
||||
! The fact that DISJOINT is private and not under lock
|
||||
! generates a certain un-repeatability, in that between
|
||||
! computing DISJOINT and assigning, another thread might
|
||||
! alter the values of ILAGGR.
|
||||
! However, a certain unrepeatability is already present
|
||||
! because the sequence of aggregates is computed with a
|
||||
! different order than in serial mode.
|
||||
! In any case, even if the enteries of ILAGGR may be
|
||||
! overwritten, the important thing is that each entry is
|
||||
! consistent and they generate a correct aggregation map.
|
||||
!
|
||||
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
|
||||
if (disjoint) then
|
||||
locnaggr(kk) = locnaggr(kk) + 1
|
||||
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
|
||||
itmp = itmp*nths+kk
|
||||
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
|
||||
!$omp atomic update
|
||||
info = max(12345678,info)
|
||||
!$omp end atomic
|
||||
cycle step1
|
||||
end if
|
||||
!$omp atomic write
|
||||
ilaggr(i) = itmp
|
||||
!$omp end atomic
|
||||
do k=1, ip
|
||||
!$omp atomic write
|
||||
ilaggr(icol(k)) = itmp
|
||||
!$omp end atomic
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
enddo step1
|
||||
end do
|
||||
!$omp end do
|
||||
|
||||
!$omp master
|
||||
naggr = sum(locnaggr(0:nths-1))
|
||||
do i=1,nths
|
||||
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
|
||||
end do
|
||||
do i=nths+1,1,-1
|
||||
locnaggr(i) = locnaggr(i-1)
|
||||
end do
|
||||
locnaggr(0) = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
!$omp do schedule(static)
|
||||
do kk=0, nths-1
|
||||
do ii=bnds(kk), bnds(kk+1)-1
|
||||
if (ilaggr(ii) > 0) then
|
||||
kp = mod(ilaggr(ii),nths)
|
||||
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end do
|
||||
end block
|
||||
!$omp end parallel
|
||||
end block
|
||||
if (info /= 0) then
|
||||
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
#else
|
||||
step1: do ii=1, nr
|
||||
if (info /= 0) cycle
|
||||
i = idxs(ii)
|
||||
if ((i<1).or.(i>nr)) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if ((nz<0).or.(nz>size(icol))) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
@@ -176,7 +353,7 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
!
|
||||
! Build the set of all strongly coupled nodes
|
||||
!
|
||||
ip = 0
|
||||
ip = 0
|
||||
do k=1, nz
|
||||
j = icol(k)
|
||||
if ((1<=j).and.(j<=nr)) then
|
||||
@@ -194,8 +371,7 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! contains I even if it does not look like it from matrix)
|
||||
!
|
||||
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
|
||||
if (disjoint) then
|
||||
icnt = icnt + 1
|
||||
if (disjoint) then
|
||||
naggr = naggr + 1
|
||||
do k=1, ip
|
||||
ilaggr(icol(k)) = naggr
|
||||
@@ -204,16 +380,22 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
endif
|
||||
enddo step1
|
||||
|
||||
#endif
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1:',count(ilaggr == -(nr+1))
|
||||
& ' Check 1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc1_p1)
|
||||
if (do_timings) call psb_tic(idx_soc1_p2)
|
||||
!
|
||||
! Phase two: join the neighbours
|
||||
!
|
||||
!$omp workshare
|
||||
tmpaggr = ilaggr
|
||||
!$omp end workshare
|
||||
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
|
||||
step2: do ii=1,nr
|
||||
i = idxs(ii)
|
||||
|
||||
@@ -244,8 +426,15 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
end if
|
||||
end do step2
|
||||
!$omp end parallel do
|
||||
if (do_timings) call psb_toc(idx_soc1_p2)
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p3)
|
||||
!
|
||||
! Phase three: sweep over leftovers, if any
|
||||
!
|
||||
@@ -274,7 +463,6 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
enddo
|
||||
if (ip > 0) then
|
||||
icnt = icnt + 1
|
||||
naggr = naggr + 1
|
||||
ilaggr(i) = naggr
|
||||
do k=1, ip
|
||||
@@ -292,7 +480,10 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end do step3
|
||||
|
||||
! Any leftovers?
|
||||
!$omp parallel do schedule(static) shared(ilaggr,info)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip)
|
||||
do i=1, nr
|
||||
if (info /= 0) cycle
|
||||
if (ilaggr(i) < 0) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if (nz == 1) then
|
||||
@@ -303,15 +494,18 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! other processes.
|
||||
ilaggr(i) = -(nrglob+nr)
|
||||
else
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
|
||||
goto 9999
|
||||
cycle
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
if (info /= 0) goto 9999
|
||||
if (do_timings) call psb_toc(idx_soc1_p3)
|
||||
if (naggr > ncol) then
|
||||
!write(0,*) name,'Error : naggr > ncol',naggr,ncol
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
|
||||
goto 9999
|
||||
@@ -336,9 +530,13 @@ subroutine amg_d_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nlaggr(:) = 0
|
||||
nlaggr(me+1) = naggr
|
||||
call psb_sum(ctxt,nlaggr(1:np))
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
call acsr%free()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+206
-16
@@ -68,9 +68,12 @@
|
||||
!
|
||||
subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_d_inner_mod
|
||||
#if defined(OPENMP)
|
||||
use omp_lib
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
|
||||
@@ -99,6 +102,9 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: nrow, ncol, n_ne
|
||||
character(len=20) :: name, ch_err
|
||||
integer(psb_ipk_), save :: idx_soc2_p1=-1, idx_soc2_p2=-1, idx_soc2_p3=-1
|
||||
integer(psb_ipk_), save :: idx_soc2_p0=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
|
||||
info=psb_success_
|
||||
name = 'amg_soc2_map_bld'
|
||||
@@ -114,6 +120,14 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
nrglob = desc_a%get_global_rows()
|
||||
if ((do_timings).and.(idx_soc2_p0==-1)) &
|
||||
& idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
|
||||
if ((do_timings).and.(idx_soc2_p1==-1)) &
|
||||
& idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
|
||||
if ((do_timings).and.(idx_soc2_p2==-1)) &
|
||||
& idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
|
||||
if ((do_timings).and.(idx_soc2_p3==-1)) &
|
||||
& idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
|
||||
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -125,6 +139,7 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc2_p0)
|
||||
diag = a%get_diag(info)
|
||||
if(info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
@@ -137,55 +152,218 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
!
|
||||
call a%cp_to(muij)
|
||||
if (clean_zeros) call muij%clean_zeros(info)
|
||||
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
|
||||
do i=1, nr
|
||||
do k=muij%irp(i),muij%irp(i+1)-1
|
||||
j = muij%ja(k)
|
||||
if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
|
||||
end do
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
!
|
||||
! Compute the 1-neigbour; mark strong links with +1, weak links with -1
|
||||
!
|
||||
call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
|
||||
ip = 0
|
||||
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
|
||||
do i=1, nr
|
||||
do k=muij%irp(i),muij%irp(i+1)-1
|
||||
j = muij%ja(k)
|
||||
s_neigh_coo%ia(k) = i
|
||||
s_neigh_coo%ja(k) = j
|
||||
if (j<=nr) then
|
||||
ip = ip + 1
|
||||
s_neigh_coo%ia(ip) = i
|
||||
s_neigh_coo%ja(ip) = j
|
||||
if (real(muij%val(k)) >= theta) then
|
||||
s_neigh_coo%val(ip) = done
|
||||
s_neigh_coo%val(k) = done
|
||||
else
|
||||
s_neigh_coo%val(ip) = -done
|
||||
s_neigh_coo%val(k) = -done
|
||||
end if
|
||||
else
|
||||
s_neigh_coo%val(k) = -done
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end parallel do
|
||||
!write(*,*) 'S_NEIGH: ',nr,ip
|
||||
call s_neigh_coo%set_nzeros(ip)
|
||||
call s_neigh_coo%set_nzeros(muij%get_nzeros())
|
||||
call s_neigh%mv_from_coo(s_neigh_coo,info)
|
||||
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
|
||||
!$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
idxs(i) = i
|
||||
end do
|
||||
!$omp end parallel do
|
||||
else
|
||||
!$omp parallel do private(i) shared(ilaggr,idxs,muij) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
ideg(i) = muij%irp(i+1) - muij%irp(i)
|
||||
end do
|
||||
!$omp end parallel do
|
||||
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc2_p0)
|
||||
if (do_timings) call psb_tic(idx_soc2_p1)
|
||||
|
||||
!
|
||||
! Phase one: Start with disjoint groups.
|
||||
!
|
||||
naggr = 0
|
||||
#if defined(OPENMP)
|
||||
block
|
||||
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
|
||||
integer(psb_ipk_) :: myth,nths, kk
|
||||
! The parallelization makes use of a locaggr(:) array; each thread
|
||||
! keeps its own version of naggr, and when the loop ends, a prefix is applied
|
||||
! to locnaggr to determine:
|
||||
! 1. The total number of aggregaters NAGGR;
|
||||
! 2. How much should each thread shift its own aggregates
|
||||
! Part 2 requires to keep track of which thread defined each entry
|
||||
! of ilaggr(), so that each entry can be adjusted correctly: even
|
||||
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
|
||||
! been set because it is strongly connected to an entry J belonging to a
|
||||
! different thread.
|
||||
|
||||
!$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
|
||||
!$omp private(icol,val,myth,kk)
|
||||
block
|
||||
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
|
||||
integer(psb_lpk_) :: itmp
|
||||
!$omp master
|
||||
nths = omp_get_num_threads()
|
||||
allocate(bnds(0:nths),locnaggr(0:nths+1))
|
||||
locnaggr(:) = 0
|
||||
bnds(0) = 1
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
myth = omp_get_thread_num()
|
||||
rsz = nr/nths
|
||||
if (myth < mod(nr,nths)) rsz = rsz + 1
|
||||
bnds(myth+1) = rsz
|
||||
!$omp barrier
|
||||
!$omp master
|
||||
do i=1,nths
|
||||
bnds(i) = bnds(i) + bnds(i-1)
|
||||
end do
|
||||
info = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
|
||||
!$omp do schedule(static) private(disjoint)
|
||||
do kk=0, nths-1
|
||||
step1: do ii=bnds(kk), bnds(kk+1)-1
|
||||
i = idxs(ii)
|
||||
if (info /= 0) then
|
||||
write(0,*) ' Step1:',kk,ii,i,info
|
||||
cycle step1
|
||||
end if
|
||||
if ((i<1).or.(i>nr)) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
!
|
||||
! Get the 1-neighbourhood of I
|
||||
!
|
||||
ip1 = s_neigh%irp(i)
|
||||
nz = s_neigh%irp(i+1)-ip1
|
||||
!
|
||||
! If the neighbourhood only contains I, skip it
|
||||
!
|
||||
if (nz ==0) then
|
||||
ilaggr(i) = 0
|
||||
cycle step1
|
||||
end if
|
||||
if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
|
||||
ilaggr(i) = 0
|
||||
cycle step1
|
||||
end if
|
||||
|
||||
nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
|
||||
icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
|
||||
disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1))
|
||||
|
||||
!
|
||||
! If the whole strongly coupled neighborhood of I is
|
||||
! as yet unconnected, turn it into the next aggregate.
|
||||
! Same if ip==0 (in which case, neighborhood only
|
||||
! contains I even if it does not look like it from matrix)
|
||||
! The fact that DISJOINT is private and not under lock
|
||||
! generates a certain un-repeatability, in that between
|
||||
! computing DISJOINT and assigning, another thread might
|
||||
! alter the values of ILAGGR.
|
||||
! However, a certain unrepeatability is already present
|
||||
! because the sequence of aggregates is computed with a
|
||||
! different order than in serial mode.
|
||||
! In any case, even if the enteries of ILAGGR may be
|
||||
! overwritten, the important thing is that each entry is
|
||||
! consistent and they generate a correct aggregation map.
|
||||
!
|
||||
if (disjoint) then
|
||||
locnaggr(kk) = locnaggr(kk) + 1
|
||||
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
|
||||
itmp = itmp*nths+kk
|
||||
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
|
||||
!$omp atomic update
|
||||
info = max(12345678,info)
|
||||
!$omp end atomic
|
||||
cycle step1
|
||||
end if
|
||||
!$omp atomic write
|
||||
ilaggr(i) = itmp
|
||||
!$omp end atomic
|
||||
do k=1, nzcnt
|
||||
!$omp atomic write
|
||||
ilaggr(icol(k)) = itmp
|
||||
!$omp end atomic
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
enddo step1
|
||||
end do
|
||||
!$omp end do
|
||||
|
||||
!$omp master
|
||||
naggr = sum(locnaggr(0:nths-1))
|
||||
do i=1,nths
|
||||
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
|
||||
end do
|
||||
do i=nths+1,1,-1
|
||||
locnaggr(i) = locnaggr(i-1)
|
||||
end do
|
||||
locnaggr(0) = 0
|
||||
!write(0,*) 'LNAG ',locnaggr(nths+1)
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
!$omp do schedule(static)
|
||||
do kk=0, nths-1
|
||||
do ii=bnds(kk), bnds(kk+1)-1
|
||||
if (ilaggr(ii) > 0) then
|
||||
kp = mod(ilaggr(ii),nths)
|
||||
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end do
|
||||
end block
|
||||
!$omp end parallel
|
||||
end block
|
||||
if (info /= 0) then
|
||||
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
#else
|
||||
icnt = 0
|
||||
step1: do ii=1, nr
|
||||
i = idxs(ii)
|
||||
@@ -224,16 +402,21 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
endif
|
||||
enddo step1
|
||||
|
||||
#endif
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1:',count(ilaggr == -(nr+1))
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc2_p1)
|
||||
if (do_timings) call psb_tic(idx_soc2_p2)
|
||||
!
|
||||
! Phase two: join the neighbours
|
||||
!
|
||||
!$omp workshare
|
||||
tmpaggr = ilaggr
|
||||
!$omp end workshare
|
||||
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
|
||||
step2: do ii=1,nr
|
||||
i = idxs(ii)
|
||||
|
||||
@@ -259,8 +442,9 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
end if
|
||||
end do step2
|
||||
|
||||
|
||||
!$omp end parallel do
|
||||
if (do_timings) call psb_toc(idx_soc2_p2)
|
||||
if (do_timings) call psb_tic(idx_soc2_p3)
|
||||
!
|
||||
! Phase three: sweep over leftovers, if any
|
||||
!
|
||||
@@ -294,6 +478,8 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end do step3
|
||||
|
||||
! Any leftovers?
|
||||
!$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)&
|
||||
!$omp private(ii,i,j,k)
|
||||
do i=1, nr
|
||||
if (ilaggr(i) <= 0) then
|
||||
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
|
||||
@@ -305,13 +491,17 @@ subroutine amg_d_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! other processes.
|
||||
ilaggr(i) = -(nrglob+nr)
|
||||
else
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
|
||||
goto 9999
|
||||
cycle
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
if (info /= 0) goto 9999
|
||||
if (do_timings) call psb_toc(idx_soc2_p3)
|
||||
if (naggr > ncol) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
|
||||
@@ -140,6 +140,9 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
real(psb_dpk_) :: anorm, omega, tmp, dg, theta
|
||||
logical, parameter :: debug_new=.false.
|
||||
character(len=80) :: filename
|
||||
logical, parameter :: do_timings=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1
|
||||
integer(psb_ipk_), save :: idx_phase3=-1, idx_cdasb=-1, idx_ptap=-1
|
||||
|
||||
name='amg_aggrmat_smth_bld'
|
||||
info=psb_success_
|
||||
@@ -153,6 +156,23 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
ctxt = desc_a%get_context()
|
||||
|
||||
call psb_info(ctxt, me, np)
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("DEC_SMTH_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_phase1==-1)) &
|
||||
& idx_phase1 = psb_get_timer_idx("DEC_SMTH_BLD: phase1 ")
|
||||
if ((do_timings).and.(idx_phase2==-1)) &
|
||||
& idx_phase2 = psb_get_timer_idx("DEC_SMTH_BLD: phase2 ")
|
||||
if ((do_timings).and.(idx_phase3==-1)) &
|
||||
& idx_phase3 = psb_get_timer_idx("DEC_SMTH_BLD: phase3 ")
|
||||
if ((do_timings).and.(idx_gtrans==-1)) &
|
||||
& idx_gtrans = psb_get_timer_idx("DEC_SMTH_BLD: gtrans ")
|
||||
if ((do_timings).and.(idx_refine==-1)) &
|
||||
& idx_refine = psb_get_timer_idx("DEC_SMTH_BLD: refine ")
|
||||
if ((do_timings).and.(idx_cdasb==-1)) &
|
||||
& idx_cdasb = psb_get_timer_idx("DEC_SMTH_BLD: cdasb ")
|
||||
if ((do_timings).and.(idx_ptap==-1)) &
|
||||
& idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld ")
|
||||
|
||||
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
@@ -171,6 +191,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
! naggr: number of local aggregates
|
||||
! nrow: local rows.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_phase1)
|
||||
|
||||
! Get the diagonal D
|
||||
adiag = a%get_diag(info)
|
||||
@@ -196,7 +217,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
!
|
||||
! Build the filtered matrix Af from A
|
||||
!
|
||||
|
||||
!$OMP parallel do private(i,j,tmp,jd) schedule(static)
|
||||
do i=1, nrow
|
||||
tmp = dzero
|
||||
jd = -1
|
||||
@@ -214,11 +235,13 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
acsrf%val(jd)=acsrf%val(jd)-tmp
|
||||
end if
|
||||
enddo
|
||||
!$OMP end parallel do
|
||||
! Take out zeroed terms
|
||||
call acsrf%clean_zeros(info)
|
||||
end if
|
||||
|
||||
|
||||
!$OMP parallel do private(i) schedule(static)
|
||||
do i=1,size(adiag)
|
||||
if (adiag(i) /= dzero) then
|
||||
adiag(i) = done / adiag(i)
|
||||
@@ -226,7 +249,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
adiag(i) = done
|
||||
end if
|
||||
end do
|
||||
|
||||
!$OMP end parallel do
|
||||
if (parms%aggr_omega_alg == amg_eig_est_) then
|
||||
|
||||
if (parms%aggr_eig == amg_max_norm_) then
|
||||
@@ -252,8 +275,9 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
|
||||
goto 9999
|
||||
end if
|
||||
if (do_timings) call psb_toc(idx_phase1)
|
||||
|
||||
|
||||
if (do_timings) call psb_tic(idx_phase2)
|
||||
call acsrf%scal(adiag,info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
@@ -267,6 +291,8 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
|
||||
call psb_cdasb(desc_ac,info)
|
||||
call psb_cd_reinit(desc_ac,info)
|
||||
if (do_timings) call psb_toc(idx_phase2)
|
||||
if (do_timings) call psb_tic(idx_phase3)
|
||||
!
|
||||
! Build the smoothed prolongator using either A or Af
|
||||
! acsr1 = (I-w*D*A) Prol acsr1 = (I-w*D*Af) Prol
|
||||
@@ -279,8 +305,8 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (do_timings) call psb_toc(idx_phase3)
|
||||
if (do_timings) call psb_tic(idx_ptap)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done SPSPMM 1'
|
||||
@@ -292,7 +318,7 @@ subroutine amg_daggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
|
||||
call op_prol%mv_from(coo_prol)
|
||||
call op_restr%mv_from(coo_restr)
|
||||
|
||||
if (do_timings) call psb_toc(idx_ptap)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done smooth_aggregate '
|
||||
|
||||
@@ -97,6 +97,8 @@ subroutine amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
integer(psb_lpk_) :: ntaggr
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
logical :: clean_zeros
|
||||
integer(psb_ipk_), save :: idx_map_bld=-1, idx_map_tprol=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
name='amg_s_dec_aggregator_tprol'
|
||||
call psb_erractionsave(err_act)
|
||||
@@ -108,6 +110,10 @@ subroutine amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_map_bld==-1)) &
|
||||
& idx_map_bld = psb_get_timer_idx("DEC_TPROL: map_bld")
|
||||
if ((do_timings).and.(idx_map_tprol==-1)) &
|
||||
& idx_map_tprol = psb_get_timer_idx("DEC_TPROL: map_tprol")
|
||||
|
||||
call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
|
||||
& amg_mult_ml_,is_legal_ml_cycle)
|
||||
@@ -121,10 +127,14 @@ subroutine amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
! The decoupled aggregator based on SOC measures ignores
|
||||
! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_map_bld)
|
||||
clean_zeros = ag%do_clean_zeros
|
||||
call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
|
||||
if (do_timings) call psb_toc(idx_map_bld)
|
||||
if (do_timings) call psb_tic(idx_map_tprol)
|
||||
|
||||
if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_map_tprol)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')
|
||||
|
||||
@@ -76,7 +76,7 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
|
||||
integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza
|
||||
logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
|
||||
|
||||
name='amg_ptap_bld'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
@@ -93,7 +93,11 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
|
||||
& idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_cpytrans1==-1)) &
|
||||
& idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
|
||||
if ((do_timings).and.(idx_cpytrans2==-1)) &
|
||||
& idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
|
||||
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
@@ -128,6 +132,7 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
! Ok first product done.
|
||||
|
||||
if (present(desc_ax)) then
|
||||
if (do_timings) call psb_tic(idx_cpytrans1)
|
||||
block
|
||||
call coo_prol%cp_to_coo(coo_restr,info)
|
||||
call coo_restr%set_ncols(desc_ac%get_local_cols())
|
||||
@@ -137,7 +142,7 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
call coo_restr%set_ncols(desc_ax%get_local_cols())
|
||||
end block
|
||||
call csr_restr%cp_from_coo(coo_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_cpytrans1)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
|
||||
goto 9999
|
||||
@@ -167,27 +172,28 @@ subroutine amg_s_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
|
||||
call coo_restr%transp()
|
||||
nzl = coo_restr%get_nzeros()
|
||||
nrl = desc_ac%get_local_rows()
|
||||
i=0
|
||||
nrl = desc_ac%get_local_rows()
|
||||
call coo_restr%fix(info)
|
||||
i=coo_restr%get_nzeros()
|
||||
!
|
||||
! Only keep local rows
|
||||
!
|
||||
do k=1, nzl
|
||||
if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
|
||||
i = i+1
|
||||
coo_restr%val(i) = coo_restr%val(k)
|
||||
coo_restr%ia(i) = coo_restr%ia(k)
|
||||
coo_restr%ja(i) = coo_restr%ja(k)
|
||||
search: do k=i,1,-1
|
||||
if (coo_restr%ia(k) <= nrl) then
|
||||
call coo_restr%set_nzeros(k)
|
||||
exit search
|
||||
end if
|
||||
end do
|
||||
call coo_restr%set_nzeros(i)
|
||||
call coo_restr%fix(info)
|
||||
end do search
|
||||
|
||||
nzl = coo_restr%get_nzeros()
|
||||
call coo_restr%set_nrows(desc_ac%get_local_rows())
|
||||
call coo_restr%set_ncols(desc_a%get_local_cols())
|
||||
if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
|
||||
if (do_timings) call psb_tic(idx_cpytrans2)
|
||||
|
||||
call csr_restr%cp_from_coo(coo_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_cpytrans2)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
|
||||
goto 9999
|
||||
|
||||
+219
-21
@@ -72,7 +72,9 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_s_inner_mod
|
||||
|
||||
#if defined(OPENMP)
|
||||
use omp_lib
|
||||
#endif
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
@@ -85,7 +87,7 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
|
||||
integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
|
||||
& ideg(:), idxs(:)
|
||||
integer(psb_lpk_), allocatable :: tmpaggr(:)
|
||||
real(psb_spk_), allocatable :: val(:), diag(:)
|
||||
@@ -99,6 +101,9 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_) :: nrow, ncol, n_ne
|
||||
integer(psb_lpk_) :: nrglob
|
||||
character(len=20) :: name, ch_err
|
||||
integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
|
||||
integer(psb_ipk_), save :: idx_soc1_p0=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
|
||||
info=psb_success_
|
||||
name = 'amg_soc1_map_bld'
|
||||
@@ -114,6 +119,14 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
nrglob = desc_a%get_global_rows()
|
||||
if ((do_timings).and.(idx_soc1_p0==-1)) &
|
||||
& idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
|
||||
if ((do_timings).and.(idx_soc1_p1==-1)) &
|
||||
& idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
|
||||
if ((do_timings).and.(idx_soc1_p2==-1)) &
|
||||
& idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
|
||||
if ((do_timings).and.(idx_soc1_p3==-1)) &
|
||||
& idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
|
||||
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -133,41 +146,205 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p0)
|
||||
call a%cp_to(acsr)
|
||||
if (do_timings) call psb_toc(idx_soc1_p0)
|
||||
if (clean_zeros) call acsr%clean_zeros(info)
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
!$omp parallel do private(i) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
idxs(i) = i
|
||||
idxs(i) = i
|
||||
end do
|
||||
else
|
||||
!$omp end parallel do
|
||||
else
|
||||
!$omp parallel do private(i) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
ideg(i) = acsr%irp(i+1) - acsr%irp(i)
|
||||
end do
|
||||
!$omp end parallel do
|
||||
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p1)
|
||||
|
||||
!
|
||||
! Phase one: Start with disjoint groups.
|
||||
!
|
||||
naggr = 0
|
||||
icnt = 0
|
||||
#if defined(OPENMP)
|
||||
block
|
||||
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
|
||||
integer(psb_ipk_) :: myth,nths, kk
|
||||
! The parallelization makes use of a locaggr(:) array; each thread
|
||||
! keeps its own version of naggr, and when the loop ends, a prefix is applied
|
||||
! to locnaggr to determine:
|
||||
! 1. The total number of aggregaters NAGGR;
|
||||
! 2. How much should each thread shift its own aggregates
|
||||
! Part 2 requires to keep track of which thread defined each entry
|
||||
! of ilaggr(), so that each entry can be adjusted correctly: even
|
||||
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
|
||||
! been set because it is strongly connected to an entry J belonging to a
|
||||
! different thread.
|
||||
|
||||
!$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
|
||||
!$omp private(icol,val,myth,kk)
|
||||
block
|
||||
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg, ip, rsz
|
||||
integer(psb_lpk_) :: itmp
|
||||
!$omp master
|
||||
nths = omp_get_num_threads()
|
||||
allocate(bnds(0:nths),locnaggr(0:nths+1))
|
||||
locnaggr(:) = 0
|
||||
bnds(0) = 1
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
myth = omp_get_thread_num()
|
||||
rsz = nr/nths
|
||||
if (myth < mod(nr,nths)) rsz = rsz + 1
|
||||
bnds(myth+1) = rsz
|
||||
!$omp barrier
|
||||
!$omp master
|
||||
do i=1,nths
|
||||
bnds(i) = bnds(i) + bnds(i-1)
|
||||
end do
|
||||
info = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
|
||||
!$omp do schedule(static) private(disjoint)
|
||||
do kk=0, nths-1
|
||||
step1: do ii=bnds(kk), bnds(kk+1)-1
|
||||
i = idxs(ii)
|
||||
if (info /= 0) cycle step1
|
||||
if ((i<1).or.(i>nr)) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if ((nz<0).or.(nz>size(icol))) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
|
||||
!
|
||||
! Build the set of all strongly coupled nodes
|
||||
!
|
||||
ip = 0
|
||||
do k=1, nz
|
||||
j = icol(k)
|
||||
! If any of the neighbours is already assigned,
|
||||
! we will not reset.
|
||||
if (j>nr) cycle step1
|
||||
if (ilaggr(j) > 0) cycle step1
|
||||
if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
|
||||
ip = ip + 1
|
||||
icol(ip) = icol(k)
|
||||
end if
|
||||
enddo
|
||||
|
||||
!
|
||||
! If the whole strongly coupled neighborhood of I is
|
||||
! as yet unconnected, turn it into the next aggregate.
|
||||
! Same if ip==0 (in which case, neighborhood only
|
||||
! contains I even if it does not look like it from matrix)
|
||||
! The fact that DISJOINT is private and not under lock
|
||||
! generates a certain un-repeatability, in that between
|
||||
! computing DISJOINT and assigning, another thread might
|
||||
! alter the values of ILAGGR.
|
||||
! However, a certain unrepeatability is already present
|
||||
! because the sequence of aggregates is computed with a
|
||||
! different order than in serial mode.
|
||||
! In any case, even if the enteries of ILAGGR may be
|
||||
! overwritten, the important thing is that each entry is
|
||||
! consistent and they generate a correct aggregation map.
|
||||
!
|
||||
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
|
||||
if (disjoint) then
|
||||
locnaggr(kk) = locnaggr(kk) + 1
|
||||
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
|
||||
itmp = itmp*nths+kk
|
||||
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
|
||||
!$omp atomic update
|
||||
info = max(12345678,info)
|
||||
!$omp end atomic
|
||||
cycle step1
|
||||
end if
|
||||
!$omp atomic write
|
||||
ilaggr(i) = itmp
|
||||
!$omp end atomic
|
||||
do k=1, ip
|
||||
!$omp atomic write
|
||||
ilaggr(icol(k)) = itmp
|
||||
!$omp end atomic
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
enddo step1
|
||||
end do
|
||||
!$omp end do
|
||||
|
||||
!$omp master
|
||||
naggr = sum(locnaggr(0:nths-1))
|
||||
do i=1,nths
|
||||
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
|
||||
end do
|
||||
do i=nths+1,1,-1
|
||||
locnaggr(i) = locnaggr(i-1)
|
||||
end do
|
||||
locnaggr(0) = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
!$omp do schedule(static)
|
||||
do kk=0, nths-1
|
||||
do ii=bnds(kk), bnds(kk+1)-1
|
||||
if (ilaggr(ii) > 0) then
|
||||
kp = mod(ilaggr(ii),nths)
|
||||
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end do
|
||||
end block
|
||||
!$omp end parallel
|
||||
end block
|
||||
if (info /= 0) then
|
||||
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
#else
|
||||
step1: do ii=1, nr
|
||||
if (info /= 0) cycle
|
||||
i = idxs(ii)
|
||||
if ((i<1).or.(i>nr)) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if ((nz<0).or.(nz>size(icol))) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
@@ -176,7 +353,7 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
!
|
||||
! Build the set of all strongly coupled nodes
|
||||
!
|
||||
ip = 0
|
||||
ip = 0
|
||||
do k=1, nz
|
||||
j = icol(k)
|
||||
if ((1<=j).and.(j<=nr)) then
|
||||
@@ -194,8 +371,7 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! contains I even if it does not look like it from matrix)
|
||||
!
|
||||
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
|
||||
if (disjoint) then
|
||||
icnt = icnt + 1
|
||||
if (disjoint) then
|
||||
naggr = naggr + 1
|
||||
do k=1, ip
|
||||
ilaggr(icol(k)) = naggr
|
||||
@@ -204,16 +380,22 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
endif
|
||||
enddo step1
|
||||
|
||||
#endif
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1:',count(ilaggr == -(nr+1))
|
||||
& ' Check 1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc1_p1)
|
||||
if (do_timings) call psb_tic(idx_soc1_p2)
|
||||
!
|
||||
! Phase two: join the neighbours
|
||||
!
|
||||
!$omp workshare
|
||||
tmpaggr = ilaggr
|
||||
!$omp end workshare
|
||||
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
|
||||
step2: do ii=1,nr
|
||||
i = idxs(ii)
|
||||
|
||||
@@ -244,8 +426,15 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
end if
|
||||
end do step2
|
||||
!$omp end parallel do
|
||||
if (do_timings) call psb_toc(idx_soc1_p2)
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p3)
|
||||
!
|
||||
! Phase three: sweep over leftovers, if any
|
||||
!
|
||||
@@ -274,7 +463,6 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
enddo
|
||||
if (ip > 0) then
|
||||
icnt = icnt + 1
|
||||
naggr = naggr + 1
|
||||
ilaggr(i) = naggr
|
||||
do k=1, ip
|
||||
@@ -292,7 +480,10 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end do step3
|
||||
|
||||
! Any leftovers?
|
||||
!$omp parallel do schedule(static) shared(ilaggr,info)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip)
|
||||
do i=1, nr
|
||||
if (info /= 0) cycle
|
||||
if (ilaggr(i) < 0) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if (nz == 1) then
|
||||
@@ -303,15 +494,18 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! other processes.
|
||||
ilaggr(i) = -(nrglob+nr)
|
||||
else
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
|
||||
goto 9999
|
||||
cycle
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
if (info /= 0) goto 9999
|
||||
if (do_timings) call psb_toc(idx_soc1_p3)
|
||||
if (naggr > ncol) then
|
||||
!write(0,*) name,'Error : naggr > ncol',naggr,ncol
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
|
||||
goto 9999
|
||||
@@ -336,9 +530,13 @@ subroutine amg_s_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nlaggr(:) = 0
|
||||
nlaggr(me+1) = naggr
|
||||
call psb_sum(ctxt,nlaggr(1:np))
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
call acsr%free()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+206
-16
@@ -68,9 +68,12 @@
|
||||
!
|
||||
subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_s_inner_mod
|
||||
#if defined(OPENMP)
|
||||
use omp_lib
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
|
||||
@@ -99,6 +102,9 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: nrow, ncol, n_ne
|
||||
character(len=20) :: name, ch_err
|
||||
integer(psb_ipk_), save :: idx_soc2_p1=-1, idx_soc2_p2=-1, idx_soc2_p3=-1
|
||||
integer(psb_ipk_), save :: idx_soc2_p0=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
|
||||
info=psb_success_
|
||||
name = 'amg_soc2_map_bld'
|
||||
@@ -114,6 +120,14 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
nrglob = desc_a%get_global_rows()
|
||||
if ((do_timings).and.(idx_soc2_p0==-1)) &
|
||||
& idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
|
||||
if ((do_timings).and.(idx_soc2_p1==-1)) &
|
||||
& idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
|
||||
if ((do_timings).and.(idx_soc2_p2==-1)) &
|
||||
& idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
|
||||
if ((do_timings).and.(idx_soc2_p3==-1)) &
|
||||
& idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
|
||||
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -125,6 +139,7 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc2_p0)
|
||||
diag = a%get_diag(info)
|
||||
if(info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
@@ -137,55 +152,218 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
!
|
||||
call a%cp_to(muij)
|
||||
if (clean_zeros) call muij%clean_zeros(info)
|
||||
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
|
||||
do i=1, nr
|
||||
do k=muij%irp(i),muij%irp(i+1)-1
|
||||
j = muij%ja(k)
|
||||
if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
|
||||
end do
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
!
|
||||
! Compute the 1-neigbour; mark strong links with +1, weak links with -1
|
||||
!
|
||||
call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
|
||||
ip = 0
|
||||
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
|
||||
do i=1, nr
|
||||
do k=muij%irp(i),muij%irp(i+1)-1
|
||||
j = muij%ja(k)
|
||||
s_neigh_coo%ia(k) = i
|
||||
s_neigh_coo%ja(k) = j
|
||||
if (j<=nr) then
|
||||
ip = ip + 1
|
||||
s_neigh_coo%ia(ip) = i
|
||||
s_neigh_coo%ja(ip) = j
|
||||
if (real(muij%val(k)) >= theta) then
|
||||
s_neigh_coo%val(ip) = sone
|
||||
s_neigh_coo%val(k) = sone
|
||||
else
|
||||
s_neigh_coo%val(ip) = -sone
|
||||
s_neigh_coo%val(k) = -sone
|
||||
end if
|
||||
else
|
||||
s_neigh_coo%val(k) = -sone
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end parallel do
|
||||
!write(*,*) 'S_NEIGH: ',nr,ip
|
||||
call s_neigh_coo%set_nzeros(ip)
|
||||
call s_neigh_coo%set_nzeros(muij%get_nzeros())
|
||||
call s_neigh%mv_from_coo(s_neigh_coo,info)
|
||||
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
|
||||
!$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
idxs(i) = i
|
||||
end do
|
||||
!$omp end parallel do
|
||||
else
|
||||
!$omp parallel do private(i) shared(ilaggr,idxs,muij) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
ideg(i) = muij%irp(i+1) - muij%irp(i)
|
||||
end do
|
||||
!$omp end parallel do
|
||||
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc2_p0)
|
||||
if (do_timings) call psb_tic(idx_soc2_p1)
|
||||
|
||||
!
|
||||
! Phase one: Start with disjoint groups.
|
||||
!
|
||||
naggr = 0
|
||||
#if defined(OPENMP)
|
||||
block
|
||||
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
|
||||
integer(psb_ipk_) :: myth,nths, kk
|
||||
! The parallelization makes use of a locaggr(:) array; each thread
|
||||
! keeps its own version of naggr, and when the loop ends, a prefix is applied
|
||||
! to locnaggr to determine:
|
||||
! 1. The total number of aggregaters NAGGR;
|
||||
! 2. How much should each thread shift its own aggregates
|
||||
! Part 2 requires to keep track of which thread defined each entry
|
||||
! of ilaggr(), so that each entry can be adjusted correctly: even
|
||||
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
|
||||
! been set because it is strongly connected to an entry J belonging to a
|
||||
! different thread.
|
||||
|
||||
!$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
|
||||
!$omp private(icol,val,myth,kk)
|
||||
block
|
||||
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
|
||||
integer(psb_lpk_) :: itmp
|
||||
!$omp master
|
||||
nths = omp_get_num_threads()
|
||||
allocate(bnds(0:nths),locnaggr(0:nths+1))
|
||||
locnaggr(:) = 0
|
||||
bnds(0) = 1
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
myth = omp_get_thread_num()
|
||||
rsz = nr/nths
|
||||
if (myth < mod(nr,nths)) rsz = rsz + 1
|
||||
bnds(myth+1) = rsz
|
||||
!$omp barrier
|
||||
!$omp master
|
||||
do i=1,nths
|
||||
bnds(i) = bnds(i) + bnds(i-1)
|
||||
end do
|
||||
info = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
|
||||
!$omp do schedule(static) private(disjoint)
|
||||
do kk=0, nths-1
|
||||
step1: do ii=bnds(kk), bnds(kk+1)-1
|
||||
i = idxs(ii)
|
||||
if (info /= 0) then
|
||||
write(0,*) ' Step1:',kk,ii,i,info
|
||||
cycle step1
|
||||
end if
|
||||
if ((i<1).or.(i>nr)) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
!
|
||||
! Get the 1-neighbourhood of I
|
||||
!
|
||||
ip1 = s_neigh%irp(i)
|
||||
nz = s_neigh%irp(i+1)-ip1
|
||||
!
|
||||
! If the neighbourhood only contains I, skip it
|
||||
!
|
||||
if (nz ==0) then
|
||||
ilaggr(i) = 0
|
||||
cycle step1
|
||||
end if
|
||||
if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
|
||||
ilaggr(i) = 0
|
||||
cycle step1
|
||||
end if
|
||||
|
||||
nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
|
||||
icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
|
||||
disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1))
|
||||
|
||||
!
|
||||
! If the whole strongly coupled neighborhood of I is
|
||||
! as yet unconnected, turn it into the next aggregate.
|
||||
! Same if ip==0 (in which case, neighborhood only
|
||||
! contains I even if it does not look like it from matrix)
|
||||
! The fact that DISJOINT is private and not under lock
|
||||
! generates a certain un-repeatability, in that between
|
||||
! computing DISJOINT and assigning, another thread might
|
||||
! alter the values of ILAGGR.
|
||||
! However, a certain unrepeatability is already present
|
||||
! because the sequence of aggregates is computed with a
|
||||
! different order than in serial mode.
|
||||
! In any case, even if the enteries of ILAGGR may be
|
||||
! overwritten, the important thing is that each entry is
|
||||
! consistent and they generate a correct aggregation map.
|
||||
!
|
||||
if (disjoint) then
|
||||
locnaggr(kk) = locnaggr(kk) + 1
|
||||
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
|
||||
itmp = itmp*nths+kk
|
||||
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
|
||||
!$omp atomic update
|
||||
info = max(12345678,info)
|
||||
!$omp end atomic
|
||||
cycle step1
|
||||
end if
|
||||
!$omp atomic write
|
||||
ilaggr(i) = itmp
|
||||
!$omp end atomic
|
||||
do k=1, nzcnt
|
||||
!$omp atomic write
|
||||
ilaggr(icol(k)) = itmp
|
||||
!$omp end atomic
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
enddo step1
|
||||
end do
|
||||
!$omp end do
|
||||
|
||||
!$omp master
|
||||
naggr = sum(locnaggr(0:nths-1))
|
||||
do i=1,nths
|
||||
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
|
||||
end do
|
||||
do i=nths+1,1,-1
|
||||
locnaggr(i) = locnaggr(i-1)
|
||||
end do
|
||||
locnaggr(0) = 0
|
||||
!write(0,*) 'LNAG ',locnaggr(nths+1)
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
!$omp do schedule(static)
|
||||
do kk=0, nths-1
|
||||
do ii=bnds(kk), bnds(kk+1)-1
|
||||
if (ilaggr(ii) > 0) then
|
||||
kp = mod(ilaggr(ii),nths)
|
||||
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end do
|
||||
end block
|
||||
!$omp end parallel
|
||||
end block
|
||||
if (info /= 0) then
|
||||
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
#else
|
||||
icnt = 0
|
||||
step1: do ii=1, nr
|
||||
i = idxs(ii)
|
||||
@@ -224,16 +402,21 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
endif
|
||||
enddo step1
|
||||
|
||||
#endif
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1:',count(ilaggr == -(nr+1))
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc2_p1)
|
||||
if (do_timings) call psb_tic(idx_soc2_p2)
|
||||
!
|
||||
! Phase two: join the neighbours
|
||||
!
|
||||
!$omp workshare
|
||||
tmpaggr = ilaggr
|
||||
!$omp end workshare
|
||||
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
|
||||
step2: do ii=1,nr
|
||||
i = idxs(ii)
|
||||
|
||||
@@ -259,8 +442,9 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
end if
|
||||
end do step2
|
||||
|
||||
|
||||
!$omp end parallel do
|
||||
if (do_timings) call psb_toc(idx_soc2_p2)
|
||||
if (do_timings) call psb_tic(idx_soc2_p3)
|
||||
!
|
||||
! Phase three: sweep over leftovers, if any
|
||||
!
|
||||
@@ -294,6 +478,8 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end do step3
|
||||
|
||||
! Any leftovers?
|
||||
!$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)&
|
||||
!$omp private(ii,i,j,k)
|
||||
do i=1, nr
|
||||
if (ilaggr(i) <= 0) then
|
||||
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
|
||||
@@ -305,13 +491,17 @@ subroutine amg_s_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! other processes.
|
||||
ilaggr(i) = -(nrglob+nr)
|
||||
else
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
|
||||
goto 9999
|
||||
cycle
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
if (info /= 0) goto 9999
|
||||
if (do_timings) call psb_toc(idx_soc2_p3)
|
||||
if (naggr > ncol) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
|
||||
@@ -140,6 +140,9 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
real(psb_spk_) :: anorm, omega, tmp, dg, theta
|
||||
logical, parameter :: debug_new=.false.
|
||||
character(len=80) :: filename
|
||||
logical, parameter :: do_timings=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1
|
||||
integer(psb_ipk_), save :: idx_phase3=-1, idx_cdasb=-1, idx_ptap=-1
|
||||
|
||||
name='amg_aggrmat_smth_bld'
|
||||
info=psb_success_
|
||||
@@ -153,6 +156,23 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
ctxt = desc_a%get_context()
|
||||
|
||||
call psb_info(ctxt, me, np)
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("DEC_SMTH_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_phase1==-1)) &
|
||||
& idx_phase1 = psb_get_timer_idx("DEC_SMTH_BLD: phase1 ")
|
||||
if ((do_timings).and.(idx_phase2==-1)) &
|
||||
& idx_phase2 = psb_get_timer_idx("DEC_SMTH_BLD: phase2 ")
|
||||
if ((do_timings).and.(idx_phase3==-1)) &
|
||||
& idx_phase3 = psb_get_timer_idx("DEC_SMTH_BLD: phase3 ")
|
||||
if ((do_timings).and.(idx_gtrans==-1)) &
|
||||
& idx_gtrans = psb_get_timer_idx("DEC_SMTH_BLD: gtrans ")
|
||||
if ((do_timings).and.(idx_refine==-1)) &
|
||||
& idx_refine = psb_get_timer_idx("DEC_SMTH_BLD: refine ")
|
||||
if ((do_timings).and.(idx_cdasb==-1)) &
|
||||
& idx_cdasb = psb_get_timer_idx("DEC_SMTH_BLD: cdasb ")
|
||||
if ((do_timings).and.(idx_ptap==-1)) &
|
||||
& idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld ")
|
||||
|
||||
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
@@ -171,6 +191,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
! naggr: number of local aggregates
|
||||
! nrow: local rows.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_phase1)
|
||||
|
||||
! Get the diagonal D
|
||||
adiag = a%get_diag(info)
|
||||
@@ -196,7 +217,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
!
|
||||
! Build the filtered matrix Af from A
|
||||
!
|
||||
|
||||
!$OMP parallel do private(i,j,tmp,jd) schedule(static)
|
||||
do i=1, nrow
|
||||
tmp = szero
|
||||
jd = -1
|
||||
@@ -214,11 +235,13 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
acsrf%val(jd)=acsrf%val(jd)-tmp
|
||||
end if
|
||||
enddo
|
||||
!$OMP end parallel do
|
||||
! Take out zeroed terms
|
||||
call acsrf%clean_zeros(info)
|
||||
end if
|
||||
|
||||
|
||||
!$OMP parallel do private(i) schedule(static)
|
||||
do i=1,size(adiag)
|
||||
if (adiag(i) /= szero) then
|
||||
adiag(i) = sone / adiag(i)
|
||||
@@ -226,7 +249,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
adiag(i) = sone
|
||||
end if
|
||||
end do
|
||||
|
||||
!$OMP end parallel do
|
||||
if (parms%aggr_omega_alg == amg_eig_est_) then
|
||||
|
||||
if (parms%aggr_eig == amg_max_norm_) then
|
||||
@@ -252,8 +275,9 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
|
||||
goto 9999
|
||||
end if
|
||||
if (do_timings) call psb_toc(idx_phase1)
|
||||
|
||||
|
||||
if (do_timings) call psb_tic(idx_phase2)
|
||||
call acsrf%scal(adiag,info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
@@ -267,6 +291,8 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
|
||||
call psb_cdasb(desc_ac,info)
|
||||
call psb_cd_reinit(desc_ac,info)
|
||||
if (do_timings) call psb_toc(idx_phase2)
|
||||
if (do_timings) call psb_tic(idx_phase3)
|
||||
!
|
||||
! Build the smoothed prolongator using either A or Af
|
||||
! acsr1 = (I-w*D*A) Prol acsr1 = (I-w*D*Af) Prol
|
||||
@@ -279,8 +305,8 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (do_timings) call psb_toc(idx_phase3)
|
||||
if (do_timings) call psb_tic(idx_ptap)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done SPSPMM 1'
|
||||
@@ -292,7 +318,7 @@ subroutine amg_saggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
|
||||
call op_prol%mv_from(coo_prol)
|
||||
call op_restr%mv_from(coo_restr)
|
||||
|
||||
if (do_timings) call psb_toc(idx_ptap)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done smooth_aggregate '
|
||||
|
||||
@@ -97,6 +97,8 @@ subroutine amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
integer(psb_lpk_) :: ntaggr
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
logical :: clean_zeros
|
||||
integer(psb_ipk_), save :: idx_map_bld=-1, idx_map_tprol=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
name='amg_z_dec_aggregator_tprol'
|
||||
call psb_erractionsave(err_act)
|
||||
@@ -108,6 +110,10 @@ subroutine amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_map_bld==-1)) &
|
||||
& idx_map_bld = psb_get_timer_idx("DEC_TPROL: map_bld")
|
||||
if ((do_timings).and.(idx_map_tprol==-1)) &
|
||||
& idx_map_tprol = psb_get_timer_idx("DEC_TPROL: map_tprol")
|
||||
|
||||
call amg_check_def(parms%ml_cycle,'Multilevel cycle',&
|
||||
& amg_mult_ml_,is_legal_ml_cycle)
|
||||
@@ -121,10 +127,14 @@ subroutine amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,&
|
||||
! The decoupled aggregator based on SOC measures ignores
|
||||
! ag_data except for clean_zeros; soc_map_bld is a procedure pointer.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_map_bld)
|
||||
clean_zeros = ag%do_clean_zeros
|
||||
call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
|
||||
if (do_timings) call psb_toc(idx_map_bld)
|
||||
if (do_timings) call psb_tic(idx_map_tprol)
|
||||
|
||||
if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
if (do_timings) call psb_toc(idx_map_tprol)
|
||||
if (info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol')
|
||||
|
||||
@@ -76,7 +76,7 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
integer(psb_ipk_) :: nrow, ncol, nrl, nzl, ip, nzt, i, k
|
||||
integer(psb_lpk_) :: nrsave, ncsave, nzsave, nza
|
||||
logical, parameter :: do_timings=.false., oldstyle=.false., debug=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_cpytrans1=-1, idx_cpytrans2=-1
|
||||
|
||||
name='amg_ptap_bld'
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
@@ -93,7 +93,11 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
ncol = desc_a%get_local_cols()
|
||||
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("SPMM_BLD: par_spspmm")
|
||||
& idx_spspmm = psb_get_timer_idx("PTAP_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_cpytrans1==-1)) &
|
||||
& idx_cpytrans1 = psb_get_timer_idx("PTAP_BLD: cpy&trans1")
|
||||
if ((do_timings).and.(idx_cpytrans2==-1)) &
|
||||
& idx_cpytrans2 = psb_get_timer_idx("PTAP_BLD: cpy&trans2")
|
||||
|
||||
naggr = nlaggr(me+1)
|
||||
ntaggr = sum(nlaggr)
|
||||
@@ -128,6 +132,7 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
! Ok first product done.
|
||||
|
||||
if (present(desc_ax)) then
|
||||
if (do_timings) call psb_tic(idx_cpytrans1)
|
||||
block
|
||||
call coo_prol%cp_to_coo(coo_restr,info)
|
||||
call coo_restr%set_ncols(desc_ac%get_local_cols())
|
||||
@@ -137,7 +142,7 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
call coo_restr%set_ncols(desc_ax%get_local_cols())
|
||||
end block
|
||||
call csr_restr%cp_from_coo(coo_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_cpytrans1)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
|
||||
goto 9999
|
||||
@@ -167,27 +172,28 @@ subroutine amg_z_ptap_bld(a_csr,desc_a,nlaggr,parms,ac,&
|
||||
|
||||
call coo_restr%transp()
|
||||
nzl = coo_restr%get_nzeros()
|
||||
nrl = desc_ac%get_local_rows()
|
||||
i=0
|
||||
nrl = desc_ac%get_local_rows()
|
||||
call coo_restr%fix(info)
|
||||
i=coo_restr%get_nzeros()
|
||||
!
|
||||
! Only keep local rows
|
||||
!
|
||||
do k=1, nzl
|
||||
if ((1 <= coo_restr%ia(k)) .and.(coo_restr%ia(k) <= nrl)) then
|
||||
i = i+1
|
||||
coo_restr%val(i) = coo_restr%val(k)
|
||||
coo_restr%ia(i) = coo_restr%ia(k)
|
||||
coo_restr%ja(i) = coo_restr%ja(k)
|
||||
search: do k=i,1,-1
|
||||
if (coo_restr%ia(k) <= nrl) then
|
||||
call coo_restr%set_nzeros(k)
|
||||
exit search
|
||||
end if
|
||||
end do
|
||||
call coo_restr%set_nzeros(i)
|
||||
call coo_restr%fix(info)
|
||||
end do search
|
||||
|
||||
nzl = coo_restr%get_nzeros()
|
||||
call coo_restr%set_nrows(desc_ac%get_local_rows())
|
||||
call coo_restr%set_ncols(desc_a%get_local_cols())
|
||||
if (debug) call check_coo(me,trim(name)//' Check 2 on coo_restr:',coo_restr)
|
||||
if (do_timings) call psb_tic(idx_cpytrans2)
|
||||
|
||||
call csr_restr%cp_from_coo(coo_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_cpytrans2)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv coo_restr')
|
||||
goto 9999
|
||||
|
||||
+219
-21
@@ -72,7 +72,9 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_z_inner_mod
|
||||
|
||||
#if defined(OPENMP)
|
||||
use omp_lib
|
||||
#endif
|
||||
implicit none
|
||||
|
||||
! Arguments
|
||||
@@ -85,7 +87,7 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_), allocatable :: ils(:), neigh(:), irow(:), icol(:),&
|
||||
integer(psb_ipk_), allocatable :: neigh(:), irow(:), icol(:),&
|
||||
& ideg(:), idxs(:)
|
||||
integer(psb_lpk_), allocatable :: tmpaggr(:)
|
||||
complex(psb_dpk_), allocatable :: val(:), diag(:)
|
||||
@@ -99,6 +101,9 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_) :: nrow, ncol, n_ne
|
||||
integer(psb_lpk_) :: nrglob
|
||||
character(len=20) :: name, ch_err
|
||||
integer(psb_ipk_), save :: idx_soc1_p1=-1, idx_soc1_p2=-1, idx_soc1_p3=-1
|
||||
integer(psb_ipk_), save :: idx_soc1_p0=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
|
||||
info=psb_success_
|
||||
name = 'amg_soc1_map_bld'
|
||||
@@ -114,6 +119,14 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
nrglob = desc_a%get_global_rows()
|
||||
if ((do_timings).and.(idx_soc1_p0==-1)) &
|
||||
& idx_soc1_p0 = psb_get_timer_idx("SOC1_MAP: phase0")
|
||||
if ((do_timings).and.(idx_soc1_p1==-1)) &
|
||||
& idx_soc1_p1 = psb_get_timer_idx("SOC1_MAP: phase1")
|
||||
if ((do_timings).and.(idx_soc1_p2==-1)) &
|
||||
& idx_soc1_p2 = psb_get_timer_idx("SOC1_MAP: phase2")
|
||||
if ((do_timings).and.(idx_soc1_p3==-1)) &
|
||||
& idx_soc1_p3 = psb_get_timer_idx("SOC1_MAP: phase3")
|
||||
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -133,41 +146,205 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p0)
|
||||
call a%cp_to(acsr)
|
||||
if (do_timings) call psb_toc(idx_soc1_p0)
|
||||
if (clean_zeros) call acsr%clean_zeros(info)
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
!$omp parallel do private(i) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
idxs(i) = i
|
||||
idxs(i) = i
|
||||
end do
|
||||
else
|
||||
!$omp end parallel do
|
||||
else
|
||||
!$omp parallel do private(i) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
ideg(i) = acsr%irp(i+1) - acsr%irp(i)
|
||||
end do
|
||||
!$omp end parallel do
|
||||
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p1)
|
||||
|
||||
!
|
||||
! Phase one: Start with disjoint groups.
|
||||
!
|
||||
naggr = 0
|
||||
icnt = 0
|
||||
#if defined(OPENMP)
|
||||
block
|
||||
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
|
||||
integer(psb_ipk_) :: myth,nths, kk
|
||||
! The parallelization makes use of a locaggr(:) array; each thread
|
||||
! keeps its own version of naggr, and when the loop ends, a prefix is applied
|
||||
! to locnaggr to determine:
|
||||
! 1. The total number of aggregaters NAGGR;
|
||||
! 2. How much should each thread shift its own aggregates
|
||||
! Part 2 requires to keep track of which thread defined each entry
|
||||
! of ilaggr(), so that each entry can be adjusted correctly: even
|
||||
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
|
||||
! been set because it is strongly connected to an entry J belonging to a
|
||||
! different thread.
|
||||
|
||||
!$omp parallel shared(bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
|
||||
!$omp private(icol,val,myth,kk)
|
||||
block
|
||||
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz, nc, i,j,m, nz, ilg, ip, rsz
|
||||
integer(psb_lpk_) :: itmp
|
||||
!$omp master
|
||||
nths = omp_get_num_threads()
|
||||
allocate(bnds(0:nths),locnaggr(0:nths+1))
|
||||
locnaggr(:) = 0
|
||||
bnds(0) = 1
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
myth = omp_get_thread_num()
|
||||
rsz = nr/nths
|
||||
if (myth < mod(nr,nths)) rsz = rsz + 1
|
||||
bnds(myth+1) = rsz
|
||||
!$omp barrier
|
||||
!$omp master
|
||||
do i=1,nths
|
||||
bnds(i) = bnds(i) + bnds(i-1)
|
||||
end do
|
||||
info = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
|
||||
!$omp do schedule(static) private(disjoint)
|
||||
do kk=0, nths-1
|
||||
step1: do ii=bnds(kk), bnds(kk+1)-1
|
||||
i = idxs(ii)
|
||||
if (info /= 0) cycle step1
|
||||
if ((i<1).or.(i>nr)) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if ((nz<0).or.(nz>size(icol))) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
|
||||
!
|
||||
! Build the set of all strongly coupled nodes
|
||||
!
|
||||
ip = 0
|
||||
do k=1, nz
|
||||
j = icol(k)
|
||||
! If any of the neighbours is already assigned,
|
||||
! we will not reset.
|
||||
if (j>nr) cycle step1
|
||||
if (ilaggr(j) > 0) cycle step1
|
||||
if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
|
||||
ip = ip + 1
|
||||
icol(ip) = icol(k)
|
||||
end if
|
||||
enddo
|
||||
|
||||
!
|
||||
! If the whole strongly coupled neighborhood of I is
|
||||
! as yet unconnected, turn it into the next aggregate.
|
||||
! Same if ip==0 (in which case, neighborhood only
|
||||
! contains I even if it does not look like it from matrix)
|
||||
! The fact that DISJOINT is private and not under lock
|
||||
! generates a certain un-repeatability, in that between
|
||||
! computing DISJOINT and assigning, another thread might
|
||||
! alter the values of ILAGGR.
|
||||
! However, a certain unrepeatability is already present
|
||||
! because the sequence of aggregates is computed with a
|
||||
! different order than in serial mode.
|
||||
! In any case, even if the enteries of ILAGGR may be
|
||||
! overwritten, the important thing is that each entry is
|
||||
! consistent and they generate a correct aggregation map.
|
||||
!
|
||||
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
|
||||
if (disjoint) then
|
||||
locnaggr(kk) = locnaggr(kk) + 1
|
||||
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
|
||||
itmp = itmp*nths+kk
|
||||
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
|
||||
!$omp atomic update
|
||||
info = max(12345678,info)
|
||||
!$omp end atomic
|
||||
cycle step1
|
||||
end if
|
||||
!$omp atomic write
|
||||
ilaggr(i) = itmp
|
||||
!$omp end atomic
|
||||
do k=1, ip
|
||||
!$omp atomic write
|
||||
ilaggr(icol(k)) = itmp
|
||||
!$omp end atomic
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
enddo step1
|
||||
end do
|
||||
!$omp end do
|
||||
|
||||
!$omp master
|
||||
naggr = sum(locnaggr(0:nths-1))
|
||||
do i=1,nths
|
||||
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
|
||||
end do
|
||||
do i=nths+1,1,-1
|
||||
locnaggr(i) = locnaggr(i-1)
|
||||
end do
|
||||
locnaggr(0) = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
!$omp do schedule(static)
|
||||
do kk=0, nths-1
|
||||
do ii=bnds(kk), bnds(kk+1)-1
|
||||
if (ilaggr(ii) > 0) then
|
||||
kp = mod(ilaggr(ii),nths)
|
||||
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end do
|
||||
end block
|
||||
!$omp end parallel
|
||||
end block
|
||||
if (info /= 0) then
|
||||
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
#else
|
||||
step1: do ii=1, nr
|
||||
if (info /= 0) cycle
|
||||
i = idxs(ii)
|
||||
if ((i<1).or.(i>nr)) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if ((nz<0).or.(nz>size(icol))) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
|
||||
@@ -176,7 +353,7 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
!
|
||||
! Build the set of all strongly coupled nodes
|
||||
!
|
||||
ip = 0
|
||||
ip = 0
|
||||
do k=1, nz
|
||||
j = icol(k)
|
||||
if ((1<=j).and.(j<=nr)) then
|
||||
@@ -194,8 +371,7 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! contains I even if it does not look like it from matrix)
|
||||
!
|
||||
disjoint = all(ilaggr(icol(1:ip)) == -(nr+1)).or.(ip==0)
|
||||
if (disjoint) then
|
||||
icnt = icnt + 1
|
||||
if (disjoint) then
|
||||
naggr = naggr + 1
|
||||
do k=1, ip
|
||||
ilaggr(icol(k)) = naggr
|
||||
@@ -204,16 +380,22 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
endif
|
||||
enddo step1
|
||||
|
||||
#endif
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1:',count(ilaggr == -(nr+1))
|
||||
& ' Check 1:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc1_p1)
|
||||
if (do_timings) call psb_tic(idx_soc1_p2)
|
||||
!
|
||||
! Phase two: join the neighbours
|
||||
!
|
||||
!$omp workshare
|
||||
tmpaggr = ilaggr
|
||||
!$omp end workshare
|
||||
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,theta)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
|
||||
step2: do ii=1,nr
|
||||
i = idxs(ii)
|
||||
|
||||
@@ -244,8 +426,15 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
end if
|
||||
end do step2
|
||||
!$omp end parallel do
|
||||
if (do_timings) call psb_toc(idx_soc1_p2)
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1.5:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc1_p3)
|
||||
!
|
||||
! Phase three: sweep over leftovers, if any
|
||||
!
|
||||
@@ -274,7 +463,6 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
enddo
|
||||
if (ip > 0) then
|
||||
icnt = icnt + 1
|
||||
naggr = naggr + 1
|
||||
ilaggr(i) = naggr
|
||||
do k=1, ip
|
||||
@@ -292,7 +480,10 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end do step3
|
||||
|
||||
! Any leftovers?
|
||||
!$omp parallel do schedule(static) shared(ilaggr,info)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip)
|
||||
do i=1, nr
|
||||
if (info /= 0) cycle
|
||||
if (ilaggr(i) < 0) then
|
||||
nz = (acsr%irp(i+1)-acsr%irp(i))
|
||||
if (nz == 1) then
|
||||
@@ -303,15 +494,18 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! other processes.
|
||||
ilaggr(i) = -(nrglob+nr)
|
||||
else
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
|
||||
goto 9999
|
||||
cycle
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
if (info /= 0) goto 9999
|
||||
if (do_timings) call psb_toc(idx_soc1_p3)
|
||||
if (naggr > ncol) then
|
||||
!write(0,*) name,'Error : naggr > ncol',naggr,ncol
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
|
||||
goto 9999
|
||||
@@ -336,9 +530,13 @@ subroutine amg_z_soc1_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nlaggr(:) = 0
|
||||
nlaggr(me+1) = naggr
|
||||
call psb_sum(ctxt,nlaggr(1:np))
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 2:',naggr,count(ilaggr(1:nr) == -(nr+1)), count(ilaggr(1:nr)>0),&
|
||||
& count(ilaggr(1:nr) == -(nr+1))+count(ilaggr(1:nr)>0),nr
|
||||
end if
|
||||
|
||||
call acsr%free()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
+206
-16
@@ -68,9 +68,12 @@
|
||||
!
|
||||
subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,info)
|
||||
|
||||
use psb_base_mod
|
||||
use psb_base_mod
|
||||
use amg_base_prec_type
|
||||
use amg_z_inner_mod
|
||||
#if defined(OPENMP)
|
||||
use omp_lib
|
||||
#endif
|
||||
|
||||
implicit none
|
||||
|
||||
@@ -99,6 +102,9 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
integer(psb_ipk_) :: np, me
|
||||
integer(psb_ipk_) :: nrow, ncol, n_ne
|
||||
character(len=20) :: name, ch_err
|
||||
integer(psb_ipk_), save :: idx_soc2_p1=-1, idx_soc2_p2=-1, idx_soc2_p3=-1
|
||||
integer(psb_ipk_), save :: idx_soc2_p0=-1
|
||||
logical, parameter :: do_timings=.true.
|
||||
|
||||
info=psb_success_
|
||||
name = 'amg_soc2_map_bld'
|
||||
@@ -114,6 +120,14 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
nrow = desc_a%get_local_rows()
|
||||
ncol = desc_a%get_local_cols()
|
||||
nrglob = desc_a%get_global_rows()
|
||||
if ((do_timings).and.(idx_soc2_p0==-1)) &
|
||||
& idx_soc2_p0 = psb_get_timer_idx("SOC2_MAP: phase0")
|
||||
if ((do_timings).and.(idx_soc2_p1==-1)) &
|
||||
& idx_soc2_p1 = psb_get_timer_idx("SOC2_MAP: phase1")
|
||||
if ((do_timings).and.(idx_soc2_p2==-1)) &
|
||||
& idx_soc2_p2 = psb_get_timer_idx("SOC2_MAP: phase2")
|
||||
if ((do_timings).and.(idx_soc2_p3==-1)) &
|
||||
& idx_soc2_p3 = psb_get_timer_idx("SOC2_MAP: phase3")
|
||||
|
||||
nr = a%get_nrows()
|
||||
nc = a%get_ncols()
|
||||
@@ -125,6 +139,7 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_tic(idx_soc2_p0)
|
||||
diag = a%get_diag(info)
|
||||
if(info /= psb_success_) then
|
||||
info=psb_err_from_subroutine_
|
||||
@@ -137,55 +152,218 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
!
|
||||
call a%cp_to(muij)
|
||||
if (clean_zeros) call muij%clean_zeros(info)
|
||||
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
|
||||
do i=1, nr
|
||||
do k=muij%irp(i),muij%irp(i+1)-1
|
||||
j = muij%ja(k)
|
||||
if (j<= nr) muij%val(k) = abs(muij%val(k))/sqrt(abs(diag(i)*diag(j)))
|
||||
end do
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
!
|
||||
! Compute the 1-neigbour; mark strong links with +1, weak links with -1
|
||||
!
|
||||
call s_neigh_coo%allocate(nr,nr,muij%get_nzeros())
|
||||
ip = 0
|
||||
!$omp parallel do private(i,j,k) shared(nr,diag,muij) schedule(static)
|
||||
do i=1, nr
|
||||
do k=muij%irp(i),muij%irp(i+1)-1
|
||||
j = muij%ja(k)
|
||||
s_neigh_coo%ia(k) = i
|
||||
s_neigh_coo%ja(k) = j
|
||||
if (j<=nr) then
|
||||
ip = ip + 1
|
||||
s_neigh_coo%ia(ip) = i
|
||||
s_neigh_coo%ja(ip) = j
|
||||
if (real(muij%val(k)) >= theta) then
|
||||
s_neigh_coo%val(ip) = done
|
||||
s_neigh_coo%val(k) = done
|
||||
else
|
||||
s_neigh_coo%val(ip) = -done
|
||||
s_neigh_coo%val(k) = -done
|
||||
end if
|
||||
else
|
||||
s_neigh_coo%val(k) = -done
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end parallel do
|
||||
!write(*,*) 'S_NEIGH: ',nr,ip
|
||||
call s_neigh_coo%set_nzeros(ip)
|
||||
call s_neigh_coo%set_nzeros(muij%get_nzeros())
|
||||
call s_neigh%mv_from_coo(s_neigh_coo,info)
|
||||
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
if (iorder == amg_aggr_ord_nat_) then
|
||||
|
||||
!$omp parallel do private(i) shared(ilaggr,idxs) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
idxs(i) = i
|
||||
end do
|
||||
!$omp end parallel do
|
||||
else
|
||||
!$omp parallel do private(i) shared(ilaggr,idxs,muij) schedule(static)
|
||||
do i=1, nr
|
||||
ilaggr(i) = -(nr+1)
|
||||
ideg(i) = muij%irp(i+1) - muij%irp(i)
|
||||
end do
|
||||
!$omp end parallel do
|
||||
call psb_msort(ideg,ix=idxs,dir=psb_sort_down_)
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc2_p0)
|
||||
if (do_timings) call psb_tic(idx_soc2_p1)
|
||||
|
||||
!
|
||||
! Phase one: Start with disjoint groups.
|
||||
!
|
||||
naggr = 0
|
||||
#if defined(OPENMP)
|
||||
block
|
||||
integer(psb_ipk_), allocatable :: bnds(:), locnaggr(:)
|
||||
integer(psb_ipk_) :: myth,nths, kk
|
||||
! The parallelization makes use of a locaggr(:) array; each thread
|
||||
! keeps its own version of naggr, and when the loop ends, a prefix is applied
|
||||
! to locnaggr to determine:
|
||||
! 1. The total number of aggregaters NAGGR;
|
||||
! 2. How much should each thread shift its own aggregates
|
||||
! Part 2 requires to keep track of which thread defined each entry
|
||||
! of ilaggr(), so that each entry can be adjusted correctly: even
|
||||
! if an entry I belongs to the range BNDS(TH)>BNDS(TH+1)-1, it may have
|
||||
! been set because it is strongly connected to an entry J belonging to a
|
||||
! different thread.
|
||||
|
||||
!$omp parallel shared(s_neigh,bnds,idxs,locnaggr,ilaggr,nr,naggr,diag,theta,nths,info) &
|
||||
!$omp private(icol,val,myth,kk)
|
||||
block
|
||||
integer(psb_ipk_) :: ii,nlp,k,kp,n,ia,isz,nc,i,j,m,nz,ilg,ip,rsz,ip1,nzcnt
|
||||
integer(psb_lpk_) :: itmp
|
||||
!$omp master
|
||||
nths = omp_get_num_threads()
|
||||
allocate(bnds(0:nths),locnaggr(0:nths+1))
|
||||
locnaggr(:) = 0
|
||||
bnds(0) = 1
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
myth = omp_get_thread_num()
|
||||
rsz = nr/nths
|
||||
if (myth < mod(nr,nths)) rsz = rsz + 1
|
||||
bnds(myth+1) = rsz
|
||||
!$omp barrier
|
||||
!$omp master
|
||||
do i=1,nths
|
||||
bnds(i) = bnds(i) + bnds(i-1)
|
||||
end do
|
||||
info = 0
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
|
||||
!$omp do schedule(static) private(disjoint)
|
||||
do kk=0, nths-1
|
||||
step1: do ii=bnds(kk), bnds(kk+1)-1
|
||||
i = idxs(ii)
|
||||
if (info /= 0) then
|
||||
write(0,*) ' Step1:',kk,ii,i,info
|
||||
cycle step1
|
||||
end if
|
||||
if ((i<1).or.(i>nr)) then
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name)
|
||||
cycle step1
|
||||
!goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (ilaggr(i) == -(nr+1)) then
|
||||
!
|
||||
! Get the 1-neighbourhood of I
|
||||
!
|
||||
ip1 = s_neigh%irp(i)
|
||||
nz = s_neigh%irp(i+1)-ip1
|
||||
!
|
||||
! If the neighbourhood only contains I, skip it
|
||||
!
|
||||
if (nz ==0) then
|
||||
ilaggr(i) = 0
|
||||
cycle step1
|
||||
end if
|
||||
if ((nz==1).and.(s_neigh%ja(ip1)==i)) then
|
||||
ilaggr(i) = 0
|
||||
cycle step1
|
||||
end if
|
||||
|
||||
nzcnt = count(real(s_neigh%val(ip1:ip1+nz-1)) > 0)
|
||||
icol(1:nzcnt) = pack(s_neigh%ja(ip1:ip1+nz-1),(real(s_neigh%val(ip1:ip1+nz-1)) > 0))
|
||||
disjoint = all(ilaggr(icol(1:nzcnt)) == -(nr+1))
|
||||
|
||||
!
|
||||
! If the whole strongly coupled neighborhood of I is
|
||||
! as yet unconnected, turn it into the next aggregate.
|
||||
! Same if ip==0 (in which case, neighborhood only
|
||||
! contains I even if it does not look like it from matrix)
|
||||
! The fact that DISJOINT is private and not under lock
|
||||
! generates a certain un-repeatability, in that between
|
||||
! computing DISJOINT and assigning, another thread might
|
||||
! alter the values of ILAGGR.
|
||||
! However, a certain unrepeatability is already present
|
||||
! because the sequence of aggregates is computed with a
|
||||
! different order than in serial mode.
|
||||
! In any case, even if the enteries of ILAGGR may be
|
||||
! overwritten, the important thing is that each entry is
|
||||
! consistent and they generate a correct aggregation map.
|
||||
!
|
||||
if (disjoint) then
|
||||
locnaggr(kk) = locnaggr(kk) + 1
|
||||
itmp = (bnds(kk)-1+locnaggr(kk)) !be careful about overflow
|
||||
itmp = itmp*nths+kk
|
||||
if (itmp < (bnds(kk)-1+locnaggr(kk))) then
|
||||
!$omp atomic update
|
||||
info = max(12345678,info)
|
||||
!$omp end atomic
|
||||
cycle step1
|
||||
end if
|
||||
!$omp atomic write
|
||||
ilaggr(i) = itmp
|
||||
!$omp end atomic
|
||||
do k=1, nzcnt
|
||||
!$omp atomic write
|
||||
ilaggr(icol(k)) = itmp
|
||||
!$omp end atomic
|
||||
end do
|
||||
end if
|
||||
end if
|
||||
enddo step1
|
||||
end do
|
||||
!$omp end do
|
||||
|
||||
!$omp master
|
||||
naggr = sum(locnaggr(0:nths-1))
|
||||
do i=1,nths
|
||||
locnaggr(i) = locnaggr(i) + locnaggr(i-1)
|
||||
end do
|
||||
do i=nths+1,1,-1
|
||||
locnaggr(i) = locnaggr(i-1)
|
||||
end do
|
||||
locnaggr(0) = 0
|
||||
!write(0,*) 'LNAG ',locnaggr(nths+1)
|
||||
!$omp end master
|
||||
!$omp barrier
|
||||
!$omp do schedule(static)
|
||||
do kk=0, nths-1
|
||||
do ii=bnds(kk), bnds(kk+1)-1
|
||||
if (ilaggr(ii) > 0) then
|
||||
kp = mod(ilaggr(ii),nths)
|
||||
ilaggr(ii) = (ilaggr(ii)/nths)- (bnds(kp)-1) + locnaggr(kp)
|
||||
end if
|
||||
end do
|
||||
end do
|
||||
!$omp end do
|
||||
end block
|
||||
!$omp end parallel
|
||||
end block
|
||||
if (info /= 0) then
|
||||
if (info == 12345678) write(0,*) 'Overflow in encoding ILAGGR'
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
#else
|
||||
icnt = 0
|
||||
step1: do ii=1, nr
|
||||
i = idxs(ii)
|
||||
@@ -224,16 +402,21 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
endif
|
||||
enddo step1
|
||||
|
||||
#endif
|
||||
if (debug_level >= psb_debug_outer_) then
|
||||
write(debug_unit,*) me,' ',trim(name),&
|
||||
& ' Check 1:',count(ilaggr == -(nr+1))
|
||||
end if
|
||||
|
||||
if (do_timings) call psb_toc(idx_soc2_p1)
|
||||
if (do_timings) call psb_tic(idx_soc2_p2)
|
||||
!
|
||||
! Phase two: join the neighbours
|
||||
!
|
||||
!$omp workshare
|
||||
tmpaggr = ilaggr
|
||||
!$omp end workshare
|
||||
!$omp parallel do schedule(static) shared(tmpaggr,ilaggr,nr,naggr,diag,muij,s_neigh)&
|
||||
!$omp private(ii,i,j,k,nz,icol,val,ip,cpling)
|
||||
step2: do ii=1,nr
|
||||
i = idxs(ii)
|
||||
|
||||
@@ -259,8 +442,9 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end if
|
||||
end if
|
||||
end do step2
|
||||
|
||||
|
||||
!$omp end parallel do
|
||||
if (do_timings) call psb_toc(idx_soc2_p2)
|
||||
if (do_timings) call psb_tic(idx_soc2_p3)
|
||||
!
|
||||
! Phase three: sweep over leftovers, if any
|
||||
!
|
||||
@@ -294,6 +478,8 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
end do step3
|
||||
|
||||
! Any leftovers?
|
||||
!$omp parallel do schedule(static) shared(ilaggr,s_neigh,info)&
|
||||
!$omp private(ii,i,j,k)
|
||||
do i=1, nr
|
||||
if (ilaggr(i) <= 0) then
|
||||
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
|
||||
@@ -305,13 +491,17 @@ subroutine amg_z_soc2_map_bld(iorder,theta,clean_zeros,a,desc_a,nlaggr,ilaggr,in
|
||||
! other processes.
|
||||
ilaggr(i) = -(nrglob+nr)
|
||||
else
|
||||
!$omp atomic write
|
||||
info=psb_err_internal_error_
|
||||
!$omp end atomic
|
||||
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
|
||||
goto 9999
|
||||
cycle
|
||||
endif
|
||||
end if
|
||||
end do
|
||||
|
||||
!$omp end parallel do
|
||||
if (info /= 0) goto 9999
|
||||
if (do_timings) call psb_toc(idx_soc2_p3)
|
||||
if (naggr > ncol) then
|
||||
info=psb_err_internal_error_
|
||||
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
|
||||
@@ -140,6 +140,9 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
real(psb_dpk_) :: anorm, omega, tmp, dg, theta
|
||||
logical, parameter :: debug_new=.false.
|
||||
character(len=80) :: filename
|
||||
logical, parameter :: do_timings=.false.
|
||||
integer(psb_ipk_), save :: idx_spspmm=-1, idx_phase1=-1, idx_gtrans=-1, idx_phase2=-1, idx_refine=-1
|
||||
integer(psb_ipk_), save :: idx_phase3=-1, idx_cdasb=-1, idx_ptap=-1
|
||||
|
||||
name='amg_aggrmat_smth_bld'
|
||||
info=psb_success_
|
||||
@@ -153,6 +156,23 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
ctxt = desc_a%get_context()
|
||||
|
||||
call psb_info(ctxt, me, np)
|
||||
if ((do_timings).and.(idx_spspmm==-1)) &
|
||||
& idx_spspmm = psb_get_timer_idx("DEC_SMTH_BLD: par_spspmm")
|
||||
if ((do_timings).and.(idx_phase1==-1)) &
|
||||
& idx_phase1 = psb_get_timer_idx("DEC_SMTH_BLD: phase1 ")
|
||||
if ((do_timings).and.(idx_phase2==-1)) &
|
||||
& idx_phase2 = psb_get_timer_idx("DEC_SMTH_BLD: phase2 ")
|
||||
if ((do_timings).and.(idx_phase3==-1)) &
|
||||
& idx_phase3 = psb_get_timer_idx("DEC_SMTH_BLD: phase3 ")
|
||||
if ((do_timings).and.(idx_gtrans==-1)) &
|
||||
& idx_gtrans = psb_get_timer_idx("DEC_SMTH_BLD: gtrans ")
|
||||
if ((do_timings).and.(idx_refine==-1)) &
|
||||
& idx_refine = psb_get_timer_idx("DEC_SMTH_BLD: refine ")
|
||||
if ((do_timings).and.(idx_cdasb==-1)) &
|
||||
& idx_cdasb = psb_get_timer_idx("DEC_SMTH_BLD: cdasb ")
|
||||
if ((do_timings).and.(idx_ptap==-1)) &
|
||||
& idx_ptap = psb_get_timer_idx("DEC_SMTH_BLD: ptap_bld ")
|
||||
|
||||
|
||||
nglob = desc_a%get_global_rows()
|
||||
nrow = desc_a%get_local_rows()
|
||||
@@ -171,6 +191,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
! naggr: number of local aggregates
|
||||
! nrow: local rows.
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_phase1)
|
||||
|
||||
! Get the diagonal D
|
||||
adiag = a%get_diag(info)
|
||||
@@ -196,7 +217,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
!
|
||||
! Build the filtered matrix Af from A
|
||||
!
|
||||
|
||||
!$OMP parallel do private(i,j,tmp,jd) schedule(static)
|
||||
do i=1, nrow
|
||||
tmp = zzero
|
||||
jd = -1
|
||||
@@ -214,11 +235,13 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
acsrf%val(jd)=acsrf%val(jd)-tmp
|
||||
end if
|
||||
enddo
|
||||
!$OMP end parallel do
|
||||
! Take out zeroed terms
|
||||
call acsrf%clean_zeros(info)
|
||||
end if
|
||||
|
||||
|
||||
!$OMP parallel do private(i) schedule(static)
|
||||
do i=1,size(adiag)
|
||||
if (adiag(i) /= zzero) then
|
||||
adiag(i) = zone / adiag(i)
|
||||
@@ -226,7 +249,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
adiag(i) = zone
|
||||
end if
|
||||
end do
|
||||
|
||||
!$OMP end parallel do
|
||||
if (parms%aggr_omega_alg == amg_eig_est_) then
|
||||
|
||||
if (parms%aggr_eig == amg_max_norm_) then
|
||||
@@ -252,8 +275,9 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
call psb_errpush(info,name,a_err='invalid amg_aggr_omega_alg_')
|
||||
goto 9999
|
||||
end if
|
||||
if (do_timings) call psb_toc(idx_phase1)
|
||||
|
||||
|
||||
if (do_timings) call psb_tic(idx_phase2)
|
||||
call acsrf%scal(adiag,info)
|
||||
if (info /= psb_success_) goto 9999
|
||||
|
||||
@@ -267,6 +291,8 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
|
||||
call psb_cdasb(desc_ac,info)
|
||||
call psb_cd_reinit(desc_ac,info)
|
||||
if (do_timings) call psb_toc(idx_phase2)
|
||||
if (do_timings) call psb_tic(idx_phase3)
|
||||
!
|
||||
! Build the smoothed prolongator using either A or Af
|
||||
! acsr1 = (I-w*D*A) Prol acsr1 = (I-w*D*Af) Prol
|
||||
@@ -279,8 +305,8 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
|
||||
if (do_timings) call psb_toc(idx_phase3)
|
||||
if (do_timings) call psb_tic(idx_ptap)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done SPSPMM 1'
|
||||
@@ -292,7 +318,7 @@ subroutine amg_zaggrmat_smth_bld(a,desc_a,ilaggr,nlaggr,parms,&
|
||||
|
||||
call op_prol%mv_from(coo_prol)
|
||||
call op_restr%mv_from(coo_restr)
|
||||
|
||||
if (do_timings) call psb_toc(idx_ptap)
|
||||
if (debug_level >= psb_debug_outer_) &
|
||||
& write(debug_unit,*) me,' ',trim(name),&
|
||||
& 'Done smooth_aggregate '
|
||||
|
||||
@@ -0,0 +1,90 @@
|
||||
#include "MatchBoxPC.h"
|
||||
// TODO comment
|
||||
|
||||
void clean(MilanLongInt NLVer,
|
||||
MilanInt myRank,
|
||||
MilanLongInt MessageIndex,
|
||||
vector<MPI_Request> &SRequest,
|
||||
vector<MPI_Status> &SStatus,
|
||||
MilanInt BufferSize,
|
||||
MilanLongInt *Buffer,
|
||||
MilanLongInt msgActual,
|
||||
MilanLongInt *msgActualSent,
|
||||
MilanLongInt msgInd,
|
||||
MilanLongInt *msgIndSent,
|
||||
MilanLongInt NumMessagesBundled,
|
||||
MilanReal *msgPercent)
|
||||
{
|
||||
// Cleanup Phase
|
||||
|
||||
#pragma omp parallel
|
||||
{
|
||||
#pragma omp master
|
||||
{
|
||||
#pragma omp task
|
||||
{
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ") Waitall= " << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#ifdef DEBUG_HANG_
|
||||
cout << "\n(" << myRank << ") Waitall " << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
//return;
|
||||
|
||||
MPI_Waitall(MessageIndex, &SRequest[0], &SStatus[0]);
|
||||
|
||||
// MPI_Buffer_attach(&Buffer, BufferSize); //Attach the Buffer
|
||||
if (BufferSize > 0)
|
||||
{
|
||||
MPI_Buffer_detach(&Buffer, &BufferSize); // Detach the Buffer
|
||||
free(Buffer); // Free the memory that was allocated
|
||||
}
|
||||
}
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")End of function to compute matching: " << endl;
|
||||
fflush(stdout);
|
||||
cout << "\n(" << myRank << ")myCardinality: " << myCard << endl;
|
||||
fflush(stdout);
|
||||
cout << "\n(" << myRank << ")Matching took " << finishTime - startTime << "seconds" << endl;
|
||||
fflush(stdout);
|
||||
cout << "\n(" << myRank << ")** Getting out of the matching function **" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ") Number of Ghost edges = " << numGhostEdges;
|
||||
cout << "\n(" << myRank << ") Total number of potential message X 2 = " << numGhostEdges * 2;
|
||||
cout << "\n(" << myRank << ") Number messages bundled = " << NumMessagesBundled;
|
||||
cout << "\n(" << myRank << ") Total Individual Messages sent = " << msgInd;
|
||||
if (msgInd > 0)
|
||||
{
|
||||
cout << "\n(" << myRank << ") Percentage of messages bundled = " << ((double)NumMessagesBundled / (double)(msgInd)) * 100.0 << "% \n";
|
||||
}
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#pragma omp task
|
||||
{
|
||||
*msgActualSent = msgActual;
|
||||
*msgIndSent = msgInd;
|
||||
if (msgInd > 0)
|
||||
{
|
||||
*msgPercent = ((double)NumMessagesBundled / (double)(msgInd)) * 100.0;
|
||||
}
|
||||
else
|
||||
{
|
||||
*msgPercent = 0;
|
||||
}
|
||||
}
|
||||
|
||||
#ifdef DEBUG_HANG_
|
||||
if (myRank == 0)
|
||||
cout << "\n(" << myRank << ") Done" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -0,0 +1,136 @@
|
||||
#include "MatchBoxPC.h"
|
||||
/**
|
||||
* Execute the research fr the Candidate Mate without controlling if the vertices are already matched.
|
||||
* Returns the vertices with the highest weight
|
||||
* @param adj1
|
||||
* @param adj2
|
||||
* @param verLocInd
|
||||
* @param edgeLocWeight
|
||||
* @return
|
||||
*/
|
||||
MilanLongInt firstComputeCandidateMateD(MilanLongInt adj1,
|
||||
MilanLongInt adj2,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanReal *edgeLocWeight)
|
||||
{
|
||||
MilanInt w = -1;
|
||||
MilanReal heaviestEdgeWt = MilanRealMin; // Assign the smallest Value possible first LDBL_MIN
|
||||
int finalK;
|
||||
for (int k = adj1; k < adj2; k++) {
|
||||
if ((edgeLocWeight[k] > heaviestEdgeWt) ||
|
||||
((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k]))) {
|
||||
heaviestEdgeWt = edgeLocWeight[k];
|
||||
w = verLocInd[k];
|
||||
finalK = k;
|
||||
}
|
||||
} // End of for loop
|
||||
return finalK;
|
||||
}
|
||||
|
||||
/**
|
||||
* //TODO documentation
|
||||
* @param adj1
|
||||
* @param adj2
|
||||
* @param edgeLocWeight
|
||||
* @param k
|
||||
* @param verLocInd
|
||||
* @param StartIndex
|
||||
* @param EndIndex
|
||||
* @param GMate
|
||||
* @param Mate
|
||||
* @param Ghost2LocalMap
|
||||
* @return
|
||||
*/
|
||||
MilanLongInt computeCandidateMateD(MilanLongInt adj1,
|
||||
MilanLongInt adj2,
|
||||
MilanReal *edgeLocWeight,
|
||||
MilanLongInt k,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap)
|
||||
{
|
||||
// Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
|
||||
|
||||
MilanInt w = -1;
|
||||
MilanReal heaviestEdgeWt = MilanRealMin; // Assign the smallest Value possible first LDBL_MIN
|
||||
for (k = adj1; k < adj2; k++) {
|
||||
if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap))
|
||||
continue;
|
||||
|
||||
if ((edgeLocWeight[k] > heaviestEdgeWt) ||
|
||||
((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k]))) {
|
||||
heaviestEdgeWt = edgeLocWeight[k];
|
||||
w = verLocInd[k];
|
||||
}
|
||||
} // End of for loop
|
||||
// End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
|
||||
|
||||
return w;
|
||||
}
|
||||
|
||||
|
||||
MilanLongInt firstComputeCandidateMateS(MilanLongInt adj1,
|
||||
MilanLongInt adj2,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanFloat *edgeLocWeight)
|
||||
{
|
||||
MilanInt w = -1;
|
||||
MilanFloat heaviestEdgeWt = 0.0f; // Assign the smallest
|
||||
int finalK;
|
||||
for (int k = adj1; k < adj2; k++) {
|
||||
if ((edgeLocWeight[k] > heaviestEdgeWt) ||
|
||||
((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k]))) {
|
||||
heaviestEdgeWt = edgeLocWeight[k];
|
||||
w = verLocInd[k];
|
||||
finalK = k;
|
||||
}
|
||||
} // End of for loop
|
||||
return finalK;
|
||||
}
|
||||
|
||||
/**
|
||||
* //TODO documentation
|
||||
* @param adj1
|
||||
* @param adj2
|
||||
* @param edgeLocWeight
|
||||
* @param k
|
||||
* @param verLocInd
|
||||
* @param StartIndex
|
||||
* @param EndIndex
|
||||
* @param GMate
|
||||
* @param Mate
|
||||
* @param Ghost2LocalMap
|
||||
* @return
|
||||
*/
|
||||
MilanLongInt computeCandidateMateS(MilanLongInt adj1,
|
||||
MilanLongInt adj2,
|
||||
MilanFloat *edgeLocWeight,
|
||||
MilanLongInt k,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap)
|
||||
{
|
||||
// Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
|
||||
|
||||
MilanInt w = -1;
|
||||
MilanFloat heaviestEdgeWt = 0.0f; // Assign the smallest Value
|
||||
for (k = adj1; k < adj2; k++) {
|
||||
if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap))
|
||||
continue;
|
||||
|
||||
if ((edgeLocWeight[k] > heaviestEdgeWt) ||
|
||||
((edgeLocWeight[k] == heaviestEdgeWt) && (w < verLocInd[k]))) {
|
||||
heaviestEdgeWt = edgeLocWeight[k];
|
||||
w = verLocInd[k];
|
||||
}
|
||||
} // End of for loop
|
||||
// End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
|
||||
|
||||
return w;
|
||||
}
|
||||
@@ -80,9 +80,11 @@ class staticQueue
|
||||
MilanLongInt squeueTail;
|
||||
MilanLongInt NumNodes;
|
||||
|
||||
//FIXME I had to comment this piece of code in order to make everything work.
|
||||
// why?
|
||||
//Prevent Assignment and Pass by Value:
|
||||
staticQueue(const staticQueue& src);
|
||||
staticQueue& operator=(const staticQueue& rhs);
|
||||
//staticQueue(const staticQueue& src);
|
||||
//staticQueue& operator=(const staticQueue& rhs);
|
||||
|
||||
public:
|
||||
//Constructors and Destructors
|
||||
|
||||
@@ -0,0 +1,30 @@
|
||||
#include "MatchBoxPC.h"
|
||||
void extractUChunk(
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU)
|
||||
{
|
||||
|
||||
UChunkBeingProcessed.clear();
|
||||
#pragma omp critical(U)
|
||||
{
|
||||
|
||||
if (U.empty() && !privateU.empty()) // If U is empty but there are nodes in private U
|
||||
{
|
||||
while (!privateU.empty())
|
||||
UChunkBeingProcessed.push_back(privateU.back());
|
||||
privateU.pop_back();
|
||||
}
|
||||
else
|
||||
{
|
||||
for (int i = 0; i < UCHUNK; i++)
|
||||
{ // Pop the new nodes
|
||||
if (U.empty())
|
||||
break;
|
||||
UChunkBeingProcessed.push_back(U.back());
|
||||
U.pop_back();
|
||||
}
|
||||
}
|
||||
|
||||
} // End of critical U // End of critical U
|
||||
}
|
||||
@@ -0,0 +1,28 @@
|
||||
#include "MatchBoxPC.h"
|
||||
/// Find the owner of a ghost node:
|
||||
MilanInt findOwnerOfGhost(MilanLongInt vtxIndex, MilanLongInt *mVerDistance,
|
||||
MilanInt myRank, MilanInt numProcs)
|
||||
{
|
||||
|
||||
MilanLongInt mStartInd = mVerDistance[myRank];
|
||||
MilanInt Start = 0;
|
||||
MilanInt End = numProcs;
|
||||
MilanInt Current = 0;
|
||||
|
||||
while (Start <= End)
|
||||
{
|
||||
Current = (End + Start) / 2;
|
||||
// CASE-1:
|
||||
if (mVerDistance[Current] == vtxIndex) return Current;
|
||||
else // CASE 2:
|
||||
if (mVerDistance[Current] > vtxIndex)
|
||||
End = Current - 1;
|
||||
else // CASE 3:
|
||||
Start = Current + 1;
|
||||
} // End of While()
|
||||
|
||||
if (mVerDistance[Current] > vtxIndex)
|
||||
return (Current - 1);
|
||||
|
||||
return Current;
|
||||
} // End of findOwnerOfGhost()
|
||||
@@ -0,0 +1,303 @@
|
||||
#include "MatchBoxPC.h"
|
||||
void initialize(MilanLongInt NLVer, MilanLongInt NLEdge,
|
||||
MilanLongInt StartIndex, MilanLongInt EndIndex,
|
||||
MilanLongInt *numGhostEdges,
|
||||
MilanLongInt *numGhostVertices,
|
||||
MilanLongInt *S,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verLocPtr,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
vector<MilanLongInt> &Counter,
|
||||
vector<MilanLongInt> &verGhostPtr,
|
||||
vector<MilanLongInt> &verGhostInd,
|
||||
vector<MilanLongInt> &tempCounter,
|
||||
vector<MilanLongInt> &GMate,
|
||||
vector<MilanLongInt> &Message,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
MilanLongInt *&candidateMate,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner)
|
||||
{
|
||||
|
||||
MilanLongInt insertMe = 0;
|
||||
MilanLongInt adj1, adj2;
|
||||
int i, v, k, w;
|
||||
// index that starts with zero to |Vg| - 1
|
||||
map<MilanLongInt, MilanLongInt>::iterator storedAlready;
|
||||
|
||||
#pragma omp parallel private(insertMe, k, w, v, adj1, adj2) firstprivate(StartIndex, EndIndex) default(shared) num_threads(NUM_THREAD)
|
||||
{
|
||||
|
||||
#pragma omp single
|
||||
{
|
||||
|
||||
#ifdef TIME_TRACKER
|
||||
double Ghost2LocalInitialization = MPI_Wtime();
|
||||
#endif
|
||||
|
||||
/*
|
||||
* OMP Ghost2LocalInitialization
|
||||
* This loop analyzes all the edges and when finds a ghost edge
|
||||
* puts it in the Ghost2LocalMap.
|
||||
* A critical region is needed when inserting data in the map.
|
||||
*
|
||||
* Despite the critical region it is still productive to
|
||||
* parallelize this cycle because the critical region is exeuted
|
||||
* only when a ghost edge is found and ghost edges are a minority,
|
||||
* circa 3.5% during the tests.
|
||||
*/
|
||||
#pragma omp task depend(out \
|
||||
: *numGhostEdges, Counter, Ghost2LocalMap, insertMe, storedAlready, *numGhostVertices)
|
||||
{
|
||||
#pragma omp taskloop num_tasks(NUM_THREAD) reduction(+ \
|
||||
: numGhostEdges[:1])
|
||||
for (i = 0; i < NLEdge; i++)
|
||||
{ // O(m) - Each edge stored twice
|
||||
insertMe = verLocInd[i];
|
||||
if ((insertMe < StartIndex) || (insertMe > EndIndex))
|
||||
{ // Find a ghost
|
||||
(*numGhostEdges)++;
|
||||
#pragma omp critical
|
||||
{
|
||||
storedAlready = Ghost2LocalMap.find(insertMe);
|
||||
if (storedAlready != Ghost2LocalMap.end())
|
||||
{ // Has already been added
|
||||
Counter[storedAlready->second]++; // Increment the counter
|
||||
}
|
||||
else
|
||||
{ // Insert an entry for the ghost:
|
||||
Ghost2LocalMap[insertMe] = *numGhostVertices; // Add a map entry
|
||||
Counter.push_back(1); // Initialize the counter
|
||||
(*numGhostVertices)++; // Increment the number of ghost vertices
|
||||
} // End of else()
|
||||
}
|
||||
} // End of if ( (insertMe < StartIndex) || (insertMe > EndIndex) )
|
||||
} // End of for(ghost vertices)
|
||||
} // end of task depend
|
||||
|
||||
// *numGhostEdges = atomicNumGhostEdges;
|
||||
#ifdef TIME_TRACKER
|
||||
Ghost2LocalInitialization = MPI_Wtime() - Ghost2LocalInitialization;
|
||||
fprintf(stderr, "Ghost2LocalInitialization time: %f\n", Ghost2LocalInitialization);
|
||||
#endif
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")NGhosts:" << *numGhostVertices << " GhostEdges: " << *numGhostEdges;
|
||||
if (!Ghost2LocalMap.empty())
|
||||
{
|
||||
cout << "\n(" << myRank << ")Final Map : on process ";
|
||||
cout << "\n(" << myRank << ")Key \t Value \t Counter \n";
|
||||
fflush(stdout);
|
||||
storedAlready = Ghost2LocalMap.begin();
|
||||
do
|
||||
{
|
||||
cout << storedAlready->second << " - " << storedAlready->first << " : " << Counter[storedAlready->second] << endl;
|
||||
fflush(stdout);
|
||||
storedAlready++;
|
||||
} while (storedAlready != Ghost2LocalMap.end());
|
||||
}
|
||||
#endif
|
||||
|
||||
#pragma omp task depend(out \
|
||||
: verGhostPtr, tempCounter, verGhostInd, GMate) depend(in \
|
||||
: *numGhostVertices, *numGhostEdges)
|
||||
{
|
||||
|
||||
// Initialize adjacency Lists for Ghost Vertices:
|
||||
try
|
||||
{
|
||||
verGhostPtr.reserve(*numGhostVertices + 1); // Pointer Vector
|
||||
tempCounter.reserve(*numGhostVertices); // Pointer Vector
|
||||
verGhostInd.reserve(*numGhostEdges); // Index Vector
|
||||
GMate.reserve(*numGhostVertices); // Ghost Mate Vector
|
||||
}
|
||||
catch (length_error)
|
||||
{
|
||||
cout << "Error in function algoDistEdgeApproxDominatingEdgesLinearSearch: \n";
|
||||
cout << "Not enough memory to allocate the internal variables \n";
|
||||
exit(1);
|
||||
}
|
||||
// Initialize the Vectors:
|
||||
verGhostPtr.resize(*numGhostVertices + 1, 0); // Pointer Vector
|
||||
tempCounter.resize(*numGhostVertices, 0); // Temporary Counter
|
||||
verGhostInd.resize(*numGhostEdges, -1); // Index Vector
|
||||
GMate.resize(*numGhostVertices, -1); // Temporary Counter
|
||||
verGhostPtr[0] = 0; // The first value
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Ghost Vertex Pointer: ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
} // End of task
|
||||
|
||||
#pragma omp task depend(out \
|
||||
: verGhostPtr) depend(in \
|
||||
: Counter, *numGhostVertices)
|
||||
{
|
||||
|
||||
#ifdef TIME_TRACKER
|
||||
double verGhostPtrInitialization = MPI_Wtime();
|
||||
#endif
|
||||
for (i = 0; i < *numGhostVertices; i++)
|
||||
{ // O(|Ghost Vertices|)
|
||||
verGhostPtr[i + 1] = verGhostPtr[i] + Counter[i];
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << verGhostPtr[i] << "\t";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
}
|
||||
|
||||
#ifdef TIME_TRACKER
|
||||
verGhostPtrInitialization = MPI_Wtime() - verGhostPtrInitialization;
|
||||
fprintf(stderr, "verGhostPtrInitialization time: %f\n", verGhostPtrInitialization);
|
||||
#endif
|
||||
} // End of task
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
if (*numGhostVertices > 0)
|
||||
cout << verGhostPtr[*numGhostVertices] << "\n";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef TIME_TRACKER
|
||||
double verGhostIndInitialization = MPI_Wtime();
|
||||
#endif
|
||||
|
||||
/*
|
||||
* OMP verGhostIndInitialization
|
||||
*
|
||||
* In this cycle the verGhostInd is initialized
|
||||
* with the datas related to ghost edges.
|
||||
* The check to see if a node is a ghost node is
|
||||
* executed in paralle and when a ghost node
|
||||
* is found a critical region is started.
|
||||
*
|
||||
* Despite the critical region it's still useful to
|
||||
* parallelize the for cause the ghost nodes
|
||||
* are a minority hence the critical region is executed
|
||||
* few times, circa 3.5% of the times in the tests.
|
||||
*/
|
||||
#pragma omp task depend(in \
|
||||
: insertMe, Ghost2LocalMap, tempCounter, verGhostPtr) depend(out \
|
||||
: verGhostInd)
|
||||
{
|
||||
#pragma omp taskloop num_tasks(NUM_THREAD)
|
||||
for (v = 0; v < NLVer; v++)
|
||||
{
|
||||
adj1 = verLocPtr[v]; // Vertex Pointer
|
||||
adj2 = verLocPtr[v + 1];
|
||||
for (k = adj1; k < adj2; k++)
|
||||
{
|
||||
w = verLocInd[k]; // Get the adjacent vertex
|
||||
if ((w < StartIndex) || (w > EndIndex))
|
||||
{ // Find a ghost
|
||||
#pragma omp critical
|
||||
{
|
||||
insertMe = verGhostPtr[Ghost2LocalMap[w]] + tempCounter[Ghost2LocalMap[w]]; // Where to insert
|
||||
tempCounter[Ghost2LocalMap[w]]++; // Increment the counter
|
||||
}
|
||||
verGhostInd[insertMe] = v + StartIndex; // Add the adjacency
|
||||
} // End of if((w < StartIndex) || (w > EndIndex))
|
||||
} // End of for(k)
|
||||
} // End of for (v)
|
||||
} // end of tasklopp
|
||||
|
||||
#ifdef TIME_TRACKER
|
||||
verGhostIndInitialization = MPI_Wtime() - verGhostIndInitialization;
|
||||
fprintf(stderr, "verGhostIndInitialization time: %f\n", verGhostIndInitialization);
|
||||
#endif
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Ghost Vertex Index: ";
|
||||
for (v = 0; v < *numGhostEdges; v++)
|
||||
cout << verGhostInd[v] << "\t";
|
||||
cout << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#pragma omp task depend(in \
|
||||
: *numGhostEdges) depend(out \
|
||||
: QLocalVtx, QGhostVtx, QMsgType, QOwner)
|
||||
{
|
||||
try
|
||||
{
|
||||
QLocalVtx.reserve(*numGhostEdges); // Local Vertex
|
||||
QGhostVtx.reserve(*numGhostEdges); // Ghost Vertex
|
||||
QMsgType.reserve(*numGhostEdges); // Message Type (Request/Failure)
|
||||
QOwner.reserve(*numGhostEdges); // Owner of the ghost: COmpute once and use later
|
||||
}
|
||||
catch (length_error)
|
||||
{
|
||||
cout << "Error in function algoDistEdgeApproxDominatingEdgesMessageBundling: \n";
|
||||
cout << "Not enough memory to allocate the internal variables \n";
|
||||
exit(1);
|
||||
}
|
||||
} // end of task
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Allocating CandidateMate.. ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ") Setup Time :" << *ph0_time << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef DEBUG_HANG_
|
||||
if (myRank == 0)
|
||||
cout << "\n(" << myRank << ") Setup Time :" << *ph0_time << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#pragma omp task depend(in \
|
||||
: *numGhostVertices) depend(out \
|
||||
: candidateMate, S, U, privateU, privateQLocalVtx, privateQGhostVtx, privateQMsgType, privateQOwner)
|
||||
{
|
||||
|
||||
// Allocate Data Structures:
|
||||
/*
|
||||
* candidateMate was a vector and has been replaced with an array
|
||||
* there is no point in using the vector (or maybe there is (???))
|
||||
* so I replaced it with an array wich is slightly faster
|
||||
*/
|
||||
candidateMate = new MilanLongInt[NLVer + (*numGhostVertices)];
|
||||
|
||||
*S = (*numGhostVertices); // Initialize S with number of Ghost Vertices
|
||||
|
||||
/*
|
||||
* Create the Queue Data Structure for the Dominating Set
|
||||
*
|
||||
* I had to declare the staticuQueue U before the parallel region
|
||||
* to have it in the correct scope. Since we can't change the dimension
|
||||
* of a staticQueue I had to destroy the previous object and instantiate
|
||||
* a new one of the correct size.
|
||||
*/
|
||||
//new (&U) staticQueue(NLVer + (*numGhostVertices));
|
||||
U.reserve(NLVer + (*numGhostVertices));
|
||||
|
||||
// Initialize the private vectors
|
||||
privateQLocalVtx.reserve(*numGhostVertices);
|
||||
privateQGhostVtx.reserve(*numGhostVertices);
|
||||
privateQMsgType.reserve(*numGhostVertices);
|
||||
privateQOwner.reserve(*numGhostVertices);
|
||||
privateU.reserve(*numGhostVertices);
|
||||
} // end of task
|
||||
|
||||
} // End of single region
|
||||
} // End of parallel region
|
||||
}
|
||||
@@ -0,0 +1,45 @@
|
||||
#include "MatchBoxPC.h"
|
||||
/**
|
||||
* //TODO documentation
|
||||
* @param k
|
||||
* @param verLocInd
|
||||
* @param StartIndex
|
||||
* @param EndIndex
|
||||
* @param GMate
|
||||
* @param Mate
|
||||
* @param Ghost2LocalMap
|
||||
* @return
|
||||
*/
|
||||
bool isAlreadyMatched(MilanLongInt node,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap)
|
||||
{
|
||||
|
||||
/*
|
||||
#pragma omp critical(Mate)
|
||||
{
|
||||
if ((node < StartIndex) || (node > EndIndex)) { //Is it a ghost vertex?
|
||||
result = GMate[Ghost2LocalMap[node]] >= 0;// Already matched
|
||||
} else { //A local vertex
|
||||
result = (Mate[node - StartIndex] >= 0); // Already matched
|
||||
}
|
||||
|
||||
}
|
||||
*/
|
||||
MilanLongInt val;
|
||||
if ((node < StartIndex) || (node > EndIndex)) // if ghost vertex
|
||||
{
|
||||
#pragma omp atomic read
|
||||
val = GMate[Ghost2LocalMap[node]];
|
||||
return val >= 0; // Already matched
|
||||
}
|
||||
|
||||
// If not ghost vertex
|
||||
#pragma omp atomic read
|
||||
val = Mate[node - StartIndex];
|
||||
|
||||
return val >= 0; // Already matched
|
||||
}
|
||||
@@ -0,0 +1,54 @@
|
||||
#include "MatchBoxPC.h"
|
||||
void PARALLEL_COMPUTE_CANDIDATE_MATE_BD(MilanLongInt NLVer,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanInt myRank,
|
||||
MilanReal *edgeLocWeight,
|
||||
MilanLongInt *candidateMate)
|
||||
{
|
||||
|
||||
MilanLongInt v = -1;
|
||||
|
||||
#pragma omp parallel private(v) default(shared) num_threads(NUM_THREAD)
|
||||
{
|
||||
|
||||
#pragma omp for schedule(static)
|
||||
for (v = 0; v < NLVer; v++) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Processing: " << v + StartIndex << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
|
||||
candidateMate[v] = firstComputeCandidateMateD(verLocPtr[v], verLocPtr[v + 1],
|
||||
verLocInd, edgeLocWeight);
|
||||
// End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void PARALLEL_COMPUTE_CANDIDATE_MATE_BS(MilanLongInt NLVer,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanInt myRank,
|
||||
MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *candidateMate)
|
||||
{
|
||||
|
||||
MilanLongInt v = -1;
|
||||
|
||||
#pragma omp parallel private(v) default(shared) num_threads(NUM_THREAD)
|
||||
{
|
||||
|
||||
#pragma omp for schedule(static)
|
||||
for (v = 0; v < NLVer; v++) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Processing: " << v + StartIndex << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Start: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
|
||||
candidateMate[v] = firstComputeCandidateMateS(verLocPtr[v], verLocPtr[v + 1],
|
||||
verLocInd, edgeLocWeight);
|
||||
// End: PARALLEL_COMPUTE_CANDIDATE_MATE_B(v)
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -0,0 +1,23 @@
|
||||
#include "MatchBoxPC.h"
|
||||
void PROCESS_CROSS_EDGE(MilanLongInt *edge,
|
||||
MilanLongInt *S)
|
||||
{
|
||||
// Start: PARALLEL_PROCESS_CROSS_EDGE_B
|
||||
MilanLongInt captureCounter;
|
||||
|
||||
#pragma omp atomic capture
|
||||
captureCounter = --(*edge); // Decrement
|
||||
|
||||
//assert(captureCounter >= 0);
|
||||
|
||||
if (captureCounter == 0)
|
||||
#pragma omp atomic
|
||||
(*S)--; // Decrement S
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Decrementing S: Ghost vertex " << edge << " has received all its messages";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
// End: PARALLEL_PROCESS_CROSS_EDGE_B
|
||||
}
|
||||
@@ -0,0 +1,368 @@
|
||||
#include "MatchBoxPC.h"
|
||||
void PARALLEL_PROCESS_EXPOSED_VERTEX_BD(MilanLongInt NLVer,
|
||||
MilanLongInt *candidateMate,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *Mate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanReal *edgeLocWeight,
|
||||
MilanLongInt *myCard,
|
||||
MilanLongInt *msgInd,
|
||||
MilanLongInt *NumMessagesBundled,
|
||||
MilanLongInt *S,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner)
|
||||
{
|
||||
|
||||
MilanLongInt v = -1, k = -1, w = -1, adj11 = 0, adj12 = 0, k1 = 0;
|
||||
MilanInt ghostOwner = 0, option, igw;
|
||||
|
||||
//#pragma omp parallel private(option, k, w, v, k1, adj11, adj12, ghostOwner) \
|
||||
firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, \
|
||||
privateQGhostVtx, privateQMsgType, privateQOwner) \
|
||||
default(shared) num_threads(NUM_THREAD)
|
||||
|
||||
{
|
||||
//#pragma omp for reduction(+ \
|
||||
: PCounter[:numProcs], myCard \
|
||||
[:1], msgInd \
|
||||
[:1], NumMessagesBundled \
|
||||
[:1]) \
|
||||
schedule(static)
|
||||
for (v = 0; v < NLVer; v++) {
|
||||
option = -1;
|
||||
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
k = candidateMate[v];
|
||||
candidateMate[v] = verLocInd[k];
|
||||
w = candidateMate[v];
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Processing: " << v + StartIndex << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")" << v + StartIndex << " Points to: " << w;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// If found a dominating edge:
|
||||
if (w >= 0) {
|
||||
#pragma omp critical(Matching)
|
||||
{
|
||||
if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap)) {
|
||||
w = computeCandidateMateD(verLocPtr[v], verLocPtr[v + 1], edgeLocWeight, 0,
|
||||
verLocInd, StartIndex, EndIndex,
|
||||
GMate, Mate, Ghost2LocalMap);
|
||||
candidateMate[v] = w;
|
||||
}
|
||||
}
|
||||
if (w >= 0) {
|
||||
(*myCard)++;
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // w is a ghost vertex
|
||||
option = 2;
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v + StartIndex) {
|
||||
option = 1;
|
||||
Mate[v] = w;
|
||||
GMate[Ghost2LocalMap[w]] = v + StartIndex; // w is a Ghost
|
||||
} // End of if CandidateMate[w] = v
|
||||
} // End of if a Ghost Vertex
|
||||
else { // w is a local vertex
|
||||
if (candidateMate[w - StartIndex] == (v + StartIndex)) {
|
||||
option = 3;
|
||||
Mate[v] = w; // v is local
|
||||
Mate[w - StartIndex] = v + StartIndex; // w is local
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v + StartIndex << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} // End of if ( candidateMate[w-StartIndex] == (v+StartIndex) )
|
||||
} // End of Else
|
||||
} // End of second if
|
||||
} // End of if(w >=0)
|
||||
else {
|
||||
//#pragma omp critical(adjuse)
|
||||
{
|
||||
// This piece of code is executed a really small number of times
|
||||
adj11 = verLocPtr[v];
|
||||
adj12 = verLocPtr[v + 1];
|
||||
for (k1 = adj11; k1 < adj12; k1++) {
|
||||
w = verLocInd[k1];
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a failure message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
(*msgInd)++;
|
||||
(*NumMessagesBundled)++;
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
#pragma omp atomic
|
||||
PCounter[ghostOwner]++;
|
||||
|
||||
privateQLocalVtx.push_back(v + StartIndex);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(FAILURE);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
} // End of if(GHOST)
|
||||
} // End of for loop
|
||||
}
|
||||
}
|
||||
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
|
||||
switch (option)
|
||||
{
|
||||
case -1:
|
||||
break;
|
||||
case 1:
|
||||
privateU.push_back(v + StartIndex);
|
||||
privateU.push_back(w);
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v + StartIndex << "," << w << ")";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
// Decrement the counter:
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], S);
|
||||
case 2:
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a request message (291):";
|
||||
cout << "\n(" << myRank << ")Local is: " << v + StartIndex << " Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
(*msgInd)++;
|
||||
(*NumMessagesBundled)++;
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
#pragma omp atomic
|
||||
PCounter[ghostOwner]++;
|
||||
|
||||
privateQLocalVtx.push_back(v + StartIndex);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(REQUEST);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
break;
|
||||
case 3:
|
||||
default:
|
||||
privateU.push_back(v + StartIndex);
|
||||
privateU.push_back(w);
|
||||
break;
|
||||
}
|
||||
|
||||
} // End of for ( v=0; v < NLVer; v++ )
|
||||
|
||||
queuesTransfer(U, privateU, QLocalVtx,
|
||||
QGhostVtx,
|
||||
QMsgType, QOwner, privateQLocalVtx,
|
||||
privateQGhostVtx,
|
||||
privateQMsgType,
|
||||
privateQOwner);
|
||||
|
||||
} // End of parallel region
|
||||
}
|
||||
|
||||
|
||||
void PARALLEL_PROCESS_EXPOSED_VERTEX_BS(MilanLongInt NLVer,
|
||||
MilanLongInt *candidateMate,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *Mate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *myCard,
|
||||
MilanLongInt *msgInd,
|
||||
MilanLongInt *NumMessagesBundled,
|
||||
MilanLongInt *S,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner)
|
||||
{
|
||||
|
||||
MilanLongInt v = -1, k = -1, w = -1, adj11 = 0, adj12 = 0, k1 = 0;
|
||||
MilanInt ghostOwner = 0, option, igw;
|
||||
|
||||
//#pragma omp parallel private(option, k, w, v, k1, adj11, adj12, ghostOwner) \
|
||||
firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, \
|
||||
privateQGhostVtx, privateQMsgType, privateQOwner) \
|
||||
default(shared) num_threads(NUM_THREAD)
|
||||
|
||||
{
|
||||
//#pragma omp for reduction(+ \
|
||||
: PCounter[:numProcs], myCard \
|
||||
[:1], msgInd \
|
||||
[:1], NumMessagesBundled \
|
||||
[:1]) \
|
||||
schedule(static)
|
||||
for (v = 0; v < NLVer; v++) {
|
||||
option = -1;
|
||||
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
k = candidateMate[v];
|
||||
candidateMate[v] = verLocInd[k];
|
||||
w = candidateMate[v];
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Processing: " << v + StartIndex << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")" << v + StartIndex << " Points to: " << w;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// If found a dominating edge:
|
||||
if (w >= 0) {
|
||||
#pragma omp critical(Matching)
|
||||
{
|
||||
if (isAlreadyMatched(verLocInd[k], StartIndex, EndIndex, GMate, Mate, Ghost2LocalMap)) {
|
||||
w = computeCandidateMateS(verLocPtr[v], verLocPtr[v + 1], edgeLocWeight, 0,
|
||||
verLocInd, StartIndex, EndIndex,
|
||||
GMate, Mate, Ghost2LocalMap);
|
||||
candidateMate[v] = w;
|
||||
}
|
||||
if (w >= 0) {
|
||||
(*myCard)++;
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // w is a ghost vertex
|
||||
option = 2;
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v + StartIndex) {
|
||||
option = 1;
|
||||
Mate[v] = w;
|
||||
GMate[Ghost2LocalMap[w]] = v + StartIndex; // w is a Ghost
|
||||
} // End of if CandidateMate[w] = v
|
||||
} // End of if a Ghost Vertex
|
||||
else { // w is a local vertex
|
||||
if (candidateMate[w - StartIndex] == (v + StartIndex)) {
|
||||
option = 3;
|
||||
Mate[v] = w; // v is local
|
||||
Mate[w - StartIndex] = v + StartIndex; // w is local
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v + StartIndex << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} // End of if ( candidateMate[w-StartIndex] == (v+StartIndex) )
|
||||
} // End of Else
|
||||
} // End of second if
|
||||
}
|
||||
|
||||
} // End of if(w >=0)
|
||||
else {
|
||||
//#pragma omp critical(adjuse)
|
||||
{
|
||||
// This piece of code is executed a really small number of times
|
||||
adj11 = verLocPtr[v];
|
||||
adj12 = verLocPtr[v + 1];
|
||||
for (k1 = adj11; k1 < adj12; k1++) {
|
||||
w = verLocInd[k1];
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a failure message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
(*msgInd)++;
|
||||
(*NumMessagesBundled)++;
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
#pragma omp atomic
|
||||
PCounter[ghostOwner]++;
|
||||
|
||||
privateQLocalVtx.push_back(v + StartIndex);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(FAILURE);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
} // End of if(GHOST)
|
||||
} // End of for loop
|
||||
}
|
||||
}
|
||||
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
|
||||
switch (option)
|
||||
{
|
||||
case -1:
|
||||
break;
|
||||
case 1:
|
||||
privateU.push_back(v + StartIndex);
|
||||
privateU.push_back(w);
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v + StartIndex << "," << w << ")";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
// Decrement the counter:
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], S);
|
||||
case 2:
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a request message (291):";
|
||||
cout << "\n(" << myRank << ")Local is: " << v + StartIndex << " Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
(*msgInd)++;
|
||||
(*NumMessagesBundled)++;
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
#pragma omp atomic
|
||||
PCounter[ghostOwner]++;
|
||||
|
||||
privateQLocalVtx.push_back(v + StartIndex);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(REQUEST);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
break;
|
||||
case 3:
|
||||
default:
|
||||
privateU.push_back(v + StartIndex);
|
||||
privateU.push_back(w);
|
||||
break;
|
||||
}
|
||||
|
||||
} // End of for ( v=0; v < NLVer; v++ )
|
||||
|
||||
queuesTransfer(U, privateU, QLocalVtx,
|
||||
QGhostVtx,
|
||||
QMsgType, QOwner, privateQLocalVtx,
|
||||
privateQGhostVtx,
|
||||
privateQMsgType,
|
||||
privateQOwner);
|
||||
|
||||
} // End of parallel region
|
||||
}
|
||||
@@ -0,0 +1,584 @@
|
||||
#include "MatchBoxPC.h"
|
||||
void processMatchedVerticesD(
|
||||
MilanLongInt NLVer,
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCard,
|
||||
MilanLongInt *msgInd,
|
||||
MilanLongInt *NumMessagesBundled,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
MilanLongInt *candidateMate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanReal *edgeLocWeight,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner)
|
||||
{
|
||||
|
||||
MilanLongInt adj1, adj2, adj11, adj12, k, k1, v = -1, w = -1, ghostOwner;
|
||||
int option;
|
||||
MilanLongInt mateVal;
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
MilanLongInt localVertices = 0;
|
||||
#endif
|
||||
//#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \
|
||||
firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, privateQGhostVtx, \
|
||||
privateQMsgType, privateQOwner, UChunkBeingProcessed) \
|
||||
default(shared) num_threads(NUM_THREAD) \
|
||||
reduction(+ \
|
||||
: msgInd[:1], PCounter \
|
||||
[:numProcs], myCard \
|
||||
[:1], NumMessagesBundled \
|
||||
[:1])
|
||||
{
|
||||
|
||||
while (!U.empty()) {
|
||||
|
||||
extractUChunk(UChunkBeingProcessed, U, privateU);
|
||||
|
||||
for (MilanLongInt u : UChunkBeingProcessed) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")u: " << u;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
if ((u >= StartIndex) && (u <= EndIndex)) { // Process Only the Local Vertices
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
localVertices++;
|
||||
#endif
|
||||
|
||||
// Get the Adjacency list for u
|
||||
adj1 = verLocPtr[u - StartIndex]; // Pointer
|
||||
adj2 = verLocPtr[u - StartIndex + 1];
|
||||
for (k = adj1; k < adj2; k++) {
|
||||
option = -1;
|
||||
v = verLocInd[k];
|
||||
|
||||
if ((v >= StartIndex) && (v <= EndIndex)) { // If Local Vertex:
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")v: " << v << " c(v)= " << candidateMate[v - StartIndex] << " Mate[v]: " << Mate[v];
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#pragma omp atomic read
|
||||
mateVal = Mate[v - StartIndex];
|
||||
// If the current vertex is pointing to a matched vertex and is not matched
|
||||
if (mateVal < 0) {
|
||||
#pragma omp critical
|
||||
{
|
||||
#pragma omp atomic read
|
||||
mateVal = Mate[v - StartIndex];
|
||||
// If the current vertex is pointing to a matched vertex and is not matched
|
||||
if (mateVal < 0) {
|
||||
|
||||
if (candidateMate[v - StartIndex] == u) {
|
||||
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
w = computeCandidateMateD(verLocPtr[v - StartIndex],
|
||||
verLocPtr[v - StartIndex + 1],
|
||||
edgeLocWeight, 0,
|
||||
verLocInd, StartIndex, EndIndex,
|
||||
GMate, Mate, Ghost2LocalMap);
|
||||
candidateMate[v - StartIndex] = w;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// If found a dominating edge:
|
||||
if (w >= 0) {
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a request message:";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
#endif
|
||||
option = 2;
|
||||
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
|
||||
option = 1;
|
||||
Mate[v - StartIndex] = w; // v is a local vertex
|
||||
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
|
||||
|
||||
} // End of if CandidateMate[w] = v
|
||||
} // End of if a Ghost Vertex
|
||||
else { // w is a local vertex
|
||||
if (candidateMate[w - StartIndex] == v) {
|
||||
option = 3;
|
||||
Mate[v - StartIndex] = w; // v is a local vertex
|
||||
Mate[w - StartIndex] = v; // w is a local vertex
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} // End of if(CandidateMate(w) = v
|
||||
} // End of Else
|
||||
} // End of if(w >=0)
|
||||
else
|
||||
option = 4; // End of Else: w == -1
|
||||
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
} // End of If (candidateMate[v-StartIndex] == u
|
||||
}
|
||||
} // End of task
|
||||
} // mateval < 0
|
||||
} // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
|
||||
else { // Neighbor is a ghost vertex
|
||||
|
||||
#pragma omp critical
|
||||
{
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
|
||||
candidateMate[NLVer + Ghost2LocalMap[v]] = -1;
|
||||
if (v != Mate[u - StartIndex])
|
||||
option = 5; // u is local
|
||||
} // End of critical
|
||||
} // End of Else //A Ghost Vertex
|
||||
|
||||
switch (option)
|
||||
{
|
||||
case -1:
|
||||
// No things to do
|
||||
break;
|
||||
case 1:
|
||||
// Found a dominating edge, it is a ghost and candidateMate[NLVer + Ghost2LocalMap[w]] == v
|
||||
privateU.push_back(v);
|
||||
privateU.push_back(w);
|
||||
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Decrement the counter:
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
|
||||
case 2:
|
||||
|
||||
// Found a dominating edge, it is a ghost
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
#pragma omp atomic
|
||||
PCounter[ghostOwner]++;
|
||||
(*NumMessagesBundled)++;
|
||||
(*msgInd)++;
|
||||
|
||||
privateQLocalVtx.push_back(v);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(REQUEST);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
break;
|
||||
case 3:
|
||||
privateU.push_back(v);
|
||||
privateU.push_back(w);
|
||||
|
||||
(*myCard)++;
|
||||
break;
|
||||
case 4:
|
||||
// Could not find a dominating vertex
|
||||
adj11 = verLocPtr[v - StartIndex];
|
||||
adj12 = verLocPtr[v - StartIndex + 1];
|
||||
for (k1 = adj11; k1 < adj12; k1++) {
|
||||
w = verLocInd[k1];
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a failure message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
#pragma omp atomic
|
||||
PCounter[ghostOwner]++;
|
||||
(*NumMessagesBundled)++;
|
||||
(*msgInd)++;
|
||||
|
||||
privateQLocalVtx.push_back(v);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(FAILURE);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
} // End of if(GHOST)
|
||||
} // End of for loop
|
||||
break;
|
||||
case 5:
|
||||
default:
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a success message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
|
||||
(*NumMessagesBundled)++;
|
||||
PCounter[ghostOwner]++;
|
||||
(*msgInd)++;
|
||||
|
||||
privateQLocalVtx.push_back(u);
|
||||
privateQGhostVtx.push_back(v);
|
||||
privateQMsgType.push_back(SUCCESS);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
break;
|
||||
} // End of switch
|
||||
} // End of inner for
|
||||
}
|
||||
} // End of outer for
|
||||
|
||||
queuesTransfer(U, privateU, QLocalVtx,
|
||||
QGhostVtx,
|
||||
QMsgType, QOwner, privateQLocalVtx,
|
||||
privateQGhostVtx,
|
||||
privateQMsgType,
|
||||
privateQOwner);
|
||||
|
||||
#pragma omp critical(U)
|
||||
{
|
||||
U.insert(U.end(), privateU.begin(), privateU.end());
|
||||
}
|
||||
|
||||
#pragma omp critical(sendMessageTransfer)
|
||||
{
|
||||
QLocalVtx.insert(QLocalVtx.end(), privateQLocalVtx.begin(), privateQLocalVtx.end());
|
||||
QGhostVtx.insert(QGhostVtx.end(), privateQGhostVtx.begin(), privateQGhostVtx.end());
|
||||
QMsgType.insert(QMsgType.end(), privateQMsgType.begin(), privateQMsgType.end());
|
||||
QOwner.insert(QOwner.end(), privateQOwner.begin(), privateQOwner.end());
|
||||
}
|
||||
|
||||
privateU.clear();
|
||||
privateQLocalVtx.clear();
|
||||
privateQGhostVtx.clear();
|
||||
privateQMsgType.clear();
|
||||
privateQOwner.clear();
|
||||
|
||||
} // End of while ( !U.empty() )
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
printf("Count local vertexes: %ld for thread %d of processor %d\n",
|
||||
localVertices,
|
||||
omp_get_thread_num(),
|
||||
myRank);
|
||||
|
||||
#endif
|
||||
} // End of parallel region
|
||||
}
|
||||
|
||||
|
||||
|
||||
void processMatchedVerticesS(
|
||||
MilanLongInt NLVer,
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCard,
|
||||
MilanLongInt *msgInd,
|
||||
MilanLongInt *NumMessagesBundled,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
MilanLongInt *candidateMate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanFloat *edgeLocWeight,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner)
|
||||
{
|
||||
|
||||
MilanLongInt adj1, adj2, adj11, adj12, k, k1, v = -1, w = -1, ghostOwner;
|
||||
int option;
|
||||
MilanLongInt mateVal;
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
MilanLongInt localVertices = 0;
|
||||
#endif
|
||||
//#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \
|
||||
firstprivate(privateU, StartIndex, EndIndex, privateQLocalVtx, privateQGhostVtx, \
|
||||
privateQMsgType, privateQOwner, UChunkBeingProcessed) \
|
||||
default(shared) num_threads(NUM_THREAD) \
|
||||
reduction(+ \
|
||||
: msgInd[:1], PCounter \
|
||||
[:numProcs], myCard \
|
||||
[:1], NumMessagesBundled \
|
||||
[:1])
|
||||
{
|
||||
|
||||
while (!U.empty()) {
|
||||
|
||||
extractUChunk(UChunkBeingProcessed, U, privateU);
|
||||
|
||||
for (MilanLongInt u : UChunkBeingProcessed) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")u: " << u;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
if ((u >= StartIndex) && (u <= EndIndex)) { // Process Only the Local Vertices
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
localVertices++;
|
||||
#endif
|
||||
|
||||
// Get the Adjacency list for u
|
||||
adj1 = verLocPtr[u - StartIndex]; // Pointer
|
||||
adj2 = verLocPtr[u - StartIndex + 1];
|
||||
for (k = adj1; k < adj2; k++) {
|
||||
option = -1;
|
||||
v = verLocInd[k];
|
||||
|
||||
if ((v >= StartIndex) && (v <= EndIndex)) { // If Local Vertex:
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")v: " << v << " c(v)= " << candidateMate[v - StartIndex] << " Mate[v]: " << Mate[v];
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#pragma omp atomic read
|
||||
mateVal = Mate[v - StartIndex];
|
||||
// If the current vertex is pointing to a matched vertex and is not matched
|
||||
if (mateVal < 0) {
|
||||
#pragma omp critical
|
||||
{
|
||||
#pragma omp atomic read
|
||||
mateVal = Mate[v - StartIndex];
|
||||
// If the current vertex is pointing to a matched vertex and is not matched
|
||||
if (mateVal < 0) {
|
||||
|
||||
if (candidateMate[v - StartIndex] == u) {
|
||||
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
w = computeCandidateMateS(verLocPtr[v - StartIndex],
|
||||
verLocPtr[v - StartIndex + 1],
|
||||
edgeLocWeight, 0,
|
||||
verLocInd, StartIndex, EndIndex,
|
||||
GMate, Mate, Ghost2LocalMap);
|
||||
candidateMate[v - StartIndex] = w;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// If found a dominating edge:
|
||||
if (w >= 0) {
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a request message:";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
#endif
|
||||
option = 2;
|
||||
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
|
||||
option = 1;
|
||||
Mate[v - StartIndex] = w; // v is a local vertex
|
||||
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
|
||||
|
||||
} // End of if CandidateMate[w] = v
|
||||
} // End of if a Ghost Vertex
|
||||
else { // w is a local vertex
|
||||
if (candidateMate[w - StartIndex] == v) {
|
||||
option = 3;
|
||||
Mate[v - StartIndex] = w; // v is a local vertex
|
||||
Mate[w - StartIndex] = v; // w is a local vertex
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} // End of if(CandidateMate(w) = v
|
||||
} // End of Else
|
||||
} // End of if(w >=0)
|
||||
else
|
||||
option = 4; // End of Else: w == -1
|
||||
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
} // End of If (candidateMate[v-StartIndex] == u
|
||||
}
|
||||
} // End of task
|
||||
} // mateval < 0
|
||||
} // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
|
||||
else { // Neighbor is a ghost vertex
|
||||
|
||||
#pragma omp critical
|
||||
{
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
|
||||
candidateMate[NLVer + Ghost2LocalMap[v]] = -1;
|
||||
if (v != Mate[u - StartIndex])
|
||||
option = 5; // u is local
|
||||
} // End of critical
|
||||
} // End of Else //A Ghost Vertex
|
||||
|
||||
switch (option)
|
||||
{
|
||||
case -1:
|
||||
// No things to do
|
||||
break;
|
||||
case 1:
|
||||
// Found a dominating edge, it is a ghost and candidateMate[NLVer + Ghost2LocalMap[w]] == v
|
||||
privateU.push_back(v);
|
||||
privateU.push_back(w);
|
||||
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Decrement the counter:
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
|
||||
case 2:
|
||||
|
||||
// Found a dominating edge, it is a ghost
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
#pragma omp atomic
|
||||
PCounter[ghostOwner]++;
|
||||
(*NumMessagesBundled)++;
|
||||
(*msgInd)++;
|
||||
|
||||
privateQLocalVtx.push_back(v);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(REQUEST);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
break;
|
||||
case 3:
|
||||
privateU.push_back(v);
|
||||
privateU.push_back(w);
|
||||
|
||||
(*myCard)++;
|
||||
break;
|
||||
case 4:
|
||||
// Could not find a dominating vertex
|
||||
adj11 = verLocPtr[v - StartIndex];
|
||||
adj12 = verLocPtr[v - StartIndex + 1];
|
||||
for (k1 = adj11; k1 < adj12; k1++) {
|
||||
w = verLocInd[k1];
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a failure message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
#pragma omp atomic
|
||||
PCounter[ghostOwner]++;
|
||||
(*NumMessagesBundled)++;
|
||||
(*msgInd)++;
|
||||
|
||||
privateQLocalVtx.push_back(v);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(FAILURE);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
} // End of if(GHOST)
|
||||
} // End of for loop
|
||||
break;
|
||||
case 5:
|
||||
default:
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a success message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
|
||||
// assert(ghostOwner != -1);
|
||||
// assert(ghostOwner != myRank);
|
||||
|
||||
(*NumMessagesBundled)++;
|
||||
PCounter[ghostOwner]++;
|
||||
(*msgInd)++;
|
||||
|
||||
privateQLocalVtx.push_back(u);
|
||||
privateQGhostVtx.push_back(v);
|
||||
privateQMsgType.push_back(SUCCESS);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
break;
|
||||
} // End of switch
|
||||
} // End of inner for
|
||||
}
|
||||
} // End of outer for
|
||||
|
||||
queuesTransfer(U, privateU, QLocalVtx,
|
||||
QGhostVtx,
|
||||
QMsgType, QOwner, privateQLocalVtx,
|
||||
privateQGhostVtx,
|
||||
privateQMsgType,
|
||||
privateQOwner);
|
||||
|
||||
#pragma omp critical(U)
|
||||
{
|
||||
U.insert(U.end(), privateU.begin(), privateU.end());
|
||||
}
|
||||
|
||||
#pragma omp critical(sendMessageTransfer)
|
||||
{
|
||||
QLocalVtx.insert(QLocalVtx.end(), privateQLocalVtx.begin(), privateQLocalVtx.end());
|
||||
QGhostVtx.insert(QGhostVtx.end(), privateQGhostVtx.begin(), privateQGhostVtx.end());
|
||||
QMsgType.insert(QMsgType.end(), privateQMsgType.begin(), privateQMsgType.end());
|
||||
QOwner.insert(QOwner.end(), privateQOwner.begin(), privateQOwner.end());
|
||||
}
|
||||
|
||||
privateU.clear();
|
||||
privateQLocalVtx.clear();
|
||||
privateQGhostVtx.clear();
|
||||
privateQMsgType.clear();
|
||||
privateQOwner.clear();
|
||||
|
||||
} // End of while ( !U.empty() )
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
printf("Count local vertexes: %ld for thread %d of processor %d\n",
|
||||
localVertices,
|
||||
omp_get_thread_num(),
|
||||
myRank);
|
||||
|
||||
#endif
|
||||
} // End of parallel region
|
||||
}
|
||||
@@ -0,0 +1,590 @@
|
||||
#include "MatchBoxPC.h"
|
||||
//#define DEBUG_HANG_
|
||||
void processMatchedVerticesAndSendMessagesD(
|
||||
MilanLongInt NLVer,
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCard,
|
||||
MilanLongInt *msgInd,
|
||||
MilanLongInt *NumMessagesBundled,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
MilanLongInt *candidateMate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanReal *edgeLocWeight,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner,
|
||||
MPI_Comm comm,
|
||||
MilanLongInt *msgActual,
|
||||
vector<MilanLongInt> &Message)
|
||||
{
|
||||
|
||||
MilanLongInt initialSize = QLocalVtx.size();
|
||||
MilanLongInt adj1, adj2, adj11, adj12, k, k1, v = -1, w = -1, ghostOwner;
|
||||
int option;
|
||||
MilanLongInt mateVal;
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
MilanLongInt localVertices = 0;
|
||||
#endif
|
||||
//#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \
|
||||
firstprivate(Message, privateU, StartIndex, EndIndex, privateQLocalVtx, \
|
||||
privateQGhostVtx, privateQMsgType, privateQOwner, UChunkBeingProcessed) \
|
||||
default(shared) \
|
||||
num_threads(NUM_THREAD) \
|
||||
reduction(+ \
|
||||
: msgInd[:1], PCounter \
|
||||
[:numProcs], myCard \
|
||||
[:1], NumMessagesBundled \
|
||||
[:1], msgActual \
|
||||
[:1])
|
||||
{
|
||||
|
||||
while (!U.empty()) {
|
||||
|
||||
extractUChunk(UChunkBeingProcessed, U, privateU);
|
||||
|
||||
for (MilanLongInt u : UChunkBeingProcessed) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")u: " << u;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
if ((u >= StartIndex) && (u <= EndIndex)) { // Process Only the Local Vertices
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
localVertices++;
|
||||
#endif
|
||||
// Get the Adjacency list for u
|
||||
adj1 = verLocPtr[u - StartIndex]; // Pointer
|
||||
adj2 = verLocPtr[u - StartIndex + 1];
|
||||
for (k = adj1; k < adj2; k++) {
|
||||
option = -1;
|
||||
v = verLocInd[k];
|
||||
|
||||
if ((v >= StartIndex) && (v <= EndIndex)) { // If Local Vertex:
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")v: " << v << " c(v)= " << candidateMate[v - StartIndex] << " Mate[v]: " << Mate[v];
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#pragma omp atomic read
|
||||
mateVal = Mate[v - StartIndex];
|
||||
// If the current vertex is pointing to a matched vertex and is not matched
|
||||
if (mateVal < 0) {
|
||||
#pragma omp critical
|
||||
{
|
||||
#pragma omp atomic read
|
||||
mateVal = Mate[v - StartIndex];
|
||||
// If the current vertex is pointing to a matched vertex and is not matched
|
||||
if (mateVal < 0) {
|
||||
|
||||
if (candidateMate[v - StartIndex] == u) {
|
||||
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
w = computeCandidateMateD(verLocPtr[v - StartIndex],
|
||||
verLocPtr[v - StartIndex + 1],
|
||||
edgeLocWeight, 0,
|
||||
verLocInd, StartIndex, EndIndex,
|
||||
GMate, Mate, Ghost2LocalMap);
|
||||
candidateMate[v - StartIndex] = w;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// If found a dominating edge:
|
||||
if (w >= 0) {
|
||||
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a request message:";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
#endif
|
||||
option = 2;
|
||||
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
|
||||
option = 1;
|
||||
Mate[v - StartIndex] = w; // v is a local vertex
|
||||
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
|
||||
|
||||
} // End of if CandidateMate[w] = v
|
||||
} // End of if a Ghost Vertex
|
||||
else { // w is a local vertex
|
||||
if (candidateMate[w - StartIndex] == v) {
|
||||
option = 3;
|
||||
Mate[v - StartIndex] = w; // v is a local vertex
|
||||
Mate[w - StartIndex] = v; // w is a local vertex
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} // End of if(CandidateMate(w) = v
|
||||
} // End of Else
|
||||
} // End of if(w >=0)
|
||||
else
|
||||
option = 4; // End of Else: w == -1
|
||||
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
} // End of If (candidateMate[v-StartIndex] == u
|
||||
}
|
||||
} // End of task
|
||||
} // mateval < 0
|
||||
} // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
|
||||
else { // Neighbor is a ghost vertex
|
||||
|
||||
#pragma omp critical
|
||||
{
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
|
||||
candidateMate[NLVer + Ghost2LocalMap[v]] = -1;
|
||||
if (v != Mate[u - StartIndex])
|
||||
option = 5; // u is local
|
||||
} // End of critical
|
||||
} // End of Else //A Ghost Vertex
|
||||
|
||||
switch (option)
|
||||
{
|
||||
case -1:
|
||||
// No things to do
|
||||
break;
|
||||
case 1:
|
||||
// Found a dominating edge, it is a ghost and candidateMate[NLVer + Ghost2LocalMap[w]] == v
|
||||
privateU.push_back(v);
|
||||
privateU.push_back(w);
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Decrement the counter:
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
|
||||
case 2:
|
||||
|
||||
// Found a dominating edge, it is a ghost
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
|
||||
// Build the Message Packet:
|
||||
// Message[0] = v; // LOCAL
|
||||
// Message[1] = w; // GHOST
|
||||
// Message[2] = REQUEST; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
|
||||
(*msgActual)++;
|
||||
(*msgInd)++;
|
||||
|
||||
privateQLocalVtx.push_back(v);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(REQUEST);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
break;
|
||||
case 3:
|
||||
privateU.push_back(v);
|
||||
privateU.push_back(w);
|
||||
(*myCard)++;
|
||||
break;
|
||||
case 4:
|
||||
// Could not find a dominating vertex
|
||||
adj11 = verLocPtr[v - StartIndex];
|
||||
adj12 = verLocPtr[v - StartIndex + 1];
|
||||
for (k1 = adj11; k1 < adj12; k1++) {
|
||||
w = verLocInd[k1];
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a failure message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// Build the Message Packet:
|
||||
// Message[0] = v; // LOCAL
|
||||
// Message[1] = w; // GHOST
|
||||
// Message[2] = FAILURE; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
|
||||
(*msgActual)++;
|
||||
(*msgInd)++;
|
||||
privateQLocalVtx.push_back(v);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(FAILURE);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
} // End of if(GHOST)
|
||||
} // End of for loop
|
||||
break;
|
||||
case 5:
|
||||
default:
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a success message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
|
||||
// Build the Message Packet:
|
||||
// Message[0] = u; // LOCAL
|
||||
// Message[1] = v; // GHOST
|
||||
// Message[2] = SUCCESS; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
(*msgActual)++;
|
||||
(*msgInd)++;
|
||||
privateQLocalVtx.push_back(u);
|
||||
privateQGhostVtx.push_back(v);
|
||||
privateQMsgType.push_back(SUCCESS);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
break;
|
||||
} // End of switch
|
||||
} // End of inner for
|
||||
}
|
||||
} // End of outer for
|
||||
|
||||
queuesTransfer(U, privateU, QLocalVtx,
|
||||
QGhostVtx,
|
||||
QMsgType, QOwner, privateQLocalVtx,
|
||||
privateQGhostVtx,
|
||||
privateQMsgType,
|
||||
privateQOwner);
|
||||
|
||||
} // End of while ( !U.empty() )
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
printf("Count local vertexes: %ld for thread %d of processor %d\n",
|
||||
localVertices, mp_get_thread_num(), myRank);
|
||||
#endif
|
||||
} // End of parallel region
|
||||
|
||||
// Send the messages
|
||||
#ifdef DEBUG_HANG_
|
||||
cout << myRank<<" Sending: "<<QOwner.size()-initialSize<<" messages" <<endl;
|
||||
#endif
|
||||
for (int i = initialSize; i < QOwner.size(); i++) {
|
||||
Message[0] = QLocalVtx[i];
|
||||
Message[1] = QGhostVtx[i];
|
||||
Message[2] = QMsgType[i];
|
||||
ghostOwner = QOwner[i];
|
||||
//MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
|
||||
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
}
|
||||
#ifdef DEBUG_HANG_
|
||||
cout << myRank<<" Done sending messages"<<endl;
|
||||
#endif
|
||||
}
|
||||
|
||||
|
||||
|
||||
void processMatchedVerticesAndSendMessagesS(
|
||||
MilanLongInt NLVer,
|
||||
vector<MilanLongInt> &UChunkBeingProcessed,
|
||||
vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCard,
|
||||
MilanLongInt *msgInd,
|
||||
MilanLongInt *NumMessagesBundled,
|
||||
MilanLongInt *SPtr,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *PCounter,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanInt myRank,
|
||||
MilanInt numProcs,
|
||||
MilanLongInt *candidateMate,
|
||||
vector<MilanLongInt> &GMate,
|
||||
MilanLongInt *Mate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
MilanFloat *edgeLocWeight,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner,
|
||||
MPI_Comm comm,
|
||||
MilanLongInt *msgActual,
|
||||
vector<MilanLongInt> &Message)
|
||||
{
|
||||
|
||||
MilanLongInt initialSize = QLocalVtx.size();
|
||||
MilanLongInt adj1, adj2, adj11, adj12, k, k1, v = -1, w = -1, ghostOwner;
|
||||
int option;
|
||||
MilanLongInt mateVal;
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
MilanLongInt localVertices = 0;
|
||||
#endif
|
||||
//#pragma omp parallel private(k, w, v, k1, adj1, adj2, adj11, adj12, ghostOwner, option) \
|
||||
firstprivate(Message, privateU, StartIndex, EndIndex, privateQLocalVtx, privateQGhostVtx,\
|
||||
privateQMsgType, privateQOwner, UChunkBeingProcessed) default(shared) \
|
||||
num_threads(NUM_THREAD) \
|
||||
reduction(+ \
|
||||
: msgInd[:1], PCounter \
|
||||
[:numProcs], myCard \
|
||||
[:1], NumMessagesBundled \
|
||||
[:1], msgActual \
|
||||
[:1])
|
||||
{
|
||||
|
||||
while (!U.empty()) {
|
||||
|
||||
extractUChunk(UChunkBeingProcessed, U, privateU);
|
||||
|
||||
for (MilanLongInt u : UChunkBeingProcessed) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")u: " << u;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
if ((u >= StartIndex) && (u <= EndIndex)) { // Process Only the Local Vertices
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
localVertices++;
|
||||
#endif
|
||||
// Get the Adjacency list for u
|
||||
adj1 = verLocPtr[u - StartIndex]; // Pointer
|
||||
adj2 = verLocPtr[u - StartIndex + 1];
|
||||
for (k = adj1; k < adj2; k++) {
|
||||
option = -1;
|
||||
v = verLocInd[k];
|
||||
|
||||
if ((v >= StartIndex) && (v <= EndIndex)) { // If Local Vertex:
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")v: " << v << " c(v)= " << candidateMate[v - StartIndex] << " Mate[v]: " << Mate[v];
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#pragma omp atomic read
|
||||
mateVal = Mate[v - StartIndex];
|
||||
// If the current vertex is pointing to a matched vertex and is not matched
|
||||
if (mateVal < 0) {
|
||||
#pragma omp critical
|
||||
{
|
||||
#pragma omp atomic read
|
||||
mateVal = Mate[v - StartIndex];
|
||||
// If the current vertex is pointing to a matched vertex and is not matched
|
||||
if (mateVal < 0) {
|
||||
|
||||
if (candidateMate[v - StartIndex] == u) {
|
||||
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
w = computeCandidateMateS(verLocPtr[v - StartIndex],
|
||||
verLocPtr[v - StartIndex + 1],
|
||||
edgeLocWeight, 0,
|
||||
verLocInd, StartIndex, EndIndex,
|
||||
GMate, Mate, Ghost2LocalMap);
|
||||
candidateMate[v - StartIndex] = w;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")" << v << " Points to: " << w;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// If found a dominating edge:
|
||||
if (w >= 0) {
|
||||
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a request message:";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
#endif
|
||||
option = 2;
|
||||
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
|
||||
option = 1;
|
||||
Mate[v - StartIndex] = w; // v is a local vertex
|
||||
GMate[Ghost2LocalMap[w]] = v; // w is a ghost vertex
|
||||
|
||||
} // End of if CandidateMate[w] = v
|
||||
} // End of if a Ghost Vertex
|
||||
else { // w is a local vertex
|
||||
if (candidateMate[w - StartIndex] == v) {
|
||||
option = 3;
|
||||
Mate[v - StartIndex] = w; // v is a local vertex
|
||||
Mate[w - StartIndex] = v; // w is a local vertex
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} // End of if(CandidateMate(w) = v
|
||||
} // End of Else
|
||||
} // End of if(w >=0)
|
||||
else
|
||||
option = 4; // End of Else: w == -1
|
||||
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
} // End of If (candidateMate[v-StartIndex] == u
|
||||
}
|
||||
} // End of task
|
||||
} // mateval < 0
|
||||
} // End of if ( (v >= StartIndex) && (v <= EndIndex) ) //If Local Vertex:
|
||||
else { // Neighbor is a ghost vertex
|
||||
|
||||
#pragma omp critical
|
||||
{
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[v]] == u)
|
||||
candidateMate[NLVer + Ghost2LocalMap[v]] = -1;
|
||||
if (v != Mate[u - StartIndex])
|
||||
option = 5; // u is local
|
||||
} // End of critical
|
||||
} // End of Else //A Ghost Vertex
|
||||
|
||||
switch (option)
|
||||
{
|
||||
case -1:
|
||||
// No things to do
|
||||
break;
|
||||
case 1:
|
||||
// Found a dominating edge, it is a ghost and candidateMate[NLVer + Ghost2LocalMap[w]] == v
|
||||
privateU.push_back(v);
|
||||
privateU.push_back(w);
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Decrement the counter:
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], SPtr);
|
||||
case 2:
|
||||
|
||||
// Found a dominating edge, it is a ghost
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
|
||||
// Build the Message Packet:
|
||||
// Message[0] = v; // LOCAL
|
||||
// Message[1] = w; // GHOST
|
||||
// Message[2] = REQUEST; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
|
||||
(*msgActual)++;
|
||||
(*msgInd)++;
|
||||
|
||||
privateQLocalVtx.push_back(v);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(REQUEST);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
break;
|
||||
case 3:
|
||||
privateU.push_back(v);
|
||||
privateU.push_back(w);
|
||||
(*myCard)++;
|
||||
break;
|
||||
case 4:
|
||||
// Could not find a dominating vertex
|
||||
adj11 = verLocPtr[v - StartIndex];
|
||||
adj12 = verLocPtr[v - StartIndex + 1];
|
||||
for (k1 = adj11; k1 < adj12; k1++) {
|
||||
w = verLocInd[k1];
|
||||
if ((w < StartIndex) || (w > EndIndex)) { // A ghost
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a failure message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
// Build the Message Packet:
|
||||
// Message[0] = v; // LOCAL
|
||||
// Message[1] = w; // GHOST
|
||||
// Message[2] = FAILURE; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
|
||||
(*msgActual)++;
|
||||
(*msgInd)++;
|
||||
privateQLocalVtx.push_back(v);
|
||||
privateQGhostVtx.push_back(w);
|
||||
privateQMsgType.push_back(FAILURE);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
} // End of if(GHOST)
|
||||
} // End of for loop
|
||||
break;
|
||||
case 5:
|
||||
default:
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a success message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << v << " Owner is: " << findOwnerOfGhost(v, verDistance, myRank, numProcs) << "\n";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
ghostOwner = findOwnerOfGhost(v, verDistance, myRank, numProcs);
|
||||
// Build the Message Packet:
|
||||
// Message[0] = u; // LOCAL
|
||||
// Message[1] = v; // GHOST
|
||||
// Message[2] = SUCCESS; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
// MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
(*msgActual)++;
|
||||
(*msgInd)++;
|
||||
privateQLocalVtx.push_back(u);
|
||||
privateQGhostVtx.push_back(v);
|
||||
privateQMsgType.push_back(SUCCESS);
|
||||
privateQOwner.push_back(ghostOwner);
|
||||
|
||||
break;
|
||||
} // End of switch
|
||||
} // End of inner for
|
||||
}
|
||||
} // End of outer for
|
||||
|
||||
queuesTransfer(U, privateU, QLocalVtx,
|
||||
QGhostVtx,
|
||||
QMsgType, QOwner, privateQLocalVtx,
|
||||
privateQGhostVtx,
|
||||
privateQMsgType,
|
||||
privateQOwner);
|
||||
|
||||
} // End of while ( !U.empty() )
|
||||
|
||||
#ifdef COUNT_LOCAL_VERTEX
|
||||
printf("Count local vertexes: %ld for thread %d of processor %d\n",
|
||||
localVertices, mp_get_thread_num(), myRank);
|
||||
#endif
|
||||
} // End of parallel region
|
||||
|
||||
// Send the messages
|
||||
#ifdef DEBUG_HANG_
|
||||
cout << myRank<<" Sending: "<<QOwner.size()-initialSize<<" messages" <<endl;
|
||||
#endif
|
||||
for (int i = initialSize; i < QOwner.size(); i++) {
|
||||
Message[0] = QLocalVtx[i];
|
||||
Message[1] = QGhostVtx[i];
|
||||
Message[2] = QMsgType[i];
|
||||
ghostOwner = QOwner[i];
|
||||
//MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
|
||||
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
}
|
||||
#ifdef DEBUG_HANG_
|
||||
cout << myRank<<" Done sending messages"<<endl;
|
||||
#endif
|
||||
}
|
||||
@@ -0,0 +1,631 @@
|
||||
#include "MatchBoxPC.h"
|
||||
//#define DEBUG_HANG_
|
||||
|
||||
void processMessagesD(
|
||||
MilanLongInt NLVer,
|
||||
MilanLongInt *Mate,
|
||||
MilanLongInt *candidateMate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
vector<MilanLongInt> &GMate,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCard,
|
||||
MilanLongInt *msgInd,
|
||||
MilanLongInt *msgActual,
|
||||
MilanReal *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt k,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanInt numProcs,
|
||||
MilanInt myRank,
|
||||
MPI_Comm comm,
|
||||
vector<MilanLongInt> &Message,
|
||||
MilanLongInt numGhostEdges,
|
||||
MilanLongInt u,
|
||||
MilanLongInt v,
|
||||
MilanLongInt *S,
|
||||
vector<MilanLongInt> &U)
|
||||
{
|
||||
|
||||
//#define PRINT_DEBUG_INFO_
|
||||
|
||||
MilanInt Sender;
|
||||
MPI_Status computeStatus;
|
||||
MilanLongInt bundleSize, w;
|
||||
MilanLongInt adj11, adj12, k1;
|
||||
MilanLongInt ghostOwner;
|
||||
int error_codeC;
|
||||
error_codeC = MPI_Comm_set_errhandler(MPI_COMM_WORLD, MPI_ERRORS_RETURN);
|
||||
char error_message[MPI_MAX_ERROR_STRING];
|
||||
int message_length;
|
||||
MilanLongInt message_type = 0;
|
||||
|
||||
// Buffer to receive bundled messages
|
||||
// Maximum messages that can be received from any processor is
|
||||
// twice the edge cut: REQUEST; REQUEST+(FAILURE/SUCCESS)
|
||||
vector<MilanLongInt> ReceiveBuffer;
|
||||
try
|
||||
{
|
||||
ReceiveBuffer.reserve(numGhostEdges * 2 * 3); // Three integers per cross edge
|
||||
}
|
||||
catch (length_error)
|
||||
{
|
||||
cout << "Error in function algoDistEdgeApproxDominatingEdgesMessageBundling: \n";
|
||||
cout << "Not enough memory to allocate the internal variables \n";
|
||||
exit(1);
|
||||
}
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout
|
||||
<< "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")About to begin Message processing phase ... *S=" << *S << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// BLOCKING RECEIVE:
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << " Waiting for blocking receive..." << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
//cout << myRank<<" Receiving ...";
|
||||
error_codeC = MPI_Recv(&Message[0], 3, TypeMap<MilanLongInt>(), MPI_ANY_SOURCE, ComputeTag, comm, &computeStatus);
|
||||
if (error_codeC != MPI_SUCCESS)
|
||||
{
|
||||
MPI_Error_string(error_codeC, error_message, &message_length);
|
||||
cout << "\n*Error in call to MPI_Receive on Slave: " << error_message << "\n";
|
||||
fflush(stdout);
|
||||
}
|
||||
Sender = computeStatus.MPI_SOURCE;
|
||||
//cout << " ...from "<<Sender << endl;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Received message from Process " << Sender << " Type= " << Message[2] << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
if (Message[2] == SIZEINFO) {
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Received bundled message from Process " << Sender << " Size= " << Message[0] << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
bundleSize = Message[0]; //#of integers in the message
|
||||
// Build the Message Buffer:
|
||||
if (!ReceiveBuffer.empty())
|
||||
ReceiveBuffer.clear(); // Empty it out first
|
||||
ReceiveBuffer.resize(bundleSize, -1); // Initialize
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message Bundle Before: " << endl;
|
||||
for (int i = 0; i < bundleSize; i++)
|
||||
cout << ReceiveBuffer[i] << ",";
|
||||
cout << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Receive the message
|
||||
//cout << myRank<<" Receiving from "<<Sender<<endl;
|
||||
error_codeC = MPI_Recv(&ReceiveBuffer[0], bundleSize, TypeMap<MilanLongInt>(), Sender, BundleTag, comm, &computeStatus);
|
||||
if (error_codeC != MPI_SUCCESS) {
|
||||
MPI_Error_string(error_codeC, error_message, &message_length);
|
||||
cout << "\n*Error in call to MPI_Receive on processor " << myRank << " Error: " << error_message << "\n";
|
||||
fflush(stdout);
|
||||
}
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message Bundle After: " << endl;
|
||||
for (int i = 0; i < bundleSize; i++)
|
||||
cout << ReceiveBuffer[i] << ",";
|
||||
cout << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} else { // Just a single message:
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Received regular message from Process " << Sender << " u= " << Message[0] << " v= " << Message[1] << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Add the current message to Queue:
|
||||
bundleSize = 3; //#of integers in the message
|
||||
// Build the Message Buffer:
|
||||
if (!ReceiveBuffer.empty())
|
||||
ReceiveBuffer.clear(); // Empty it out first
|
||||
ReceiveBuffer.resize(bundleSize, -1); // Initialize
|
||||
|
||||
ReceiveBuffer[0] = Message[0]; // u
|
||||
ReceiveBuffer[1] = Message[1]; // v
|
||||
ReceiveBuffer[2] = Message[2]; // message_type
|
||||
}
|
||||
|
||||
#ifdef DEBUG_GHOST_
|
||||
if ((v < StartIndex) || (v > EndIndex)) {
|
||||
cout << "\n(" << myRank << ") From ReceiveBuffer: This should not happen: u= " << u << " v= " << v << " Type= " << message_type << " StartIndex " << StartIndex << " EndIndex " << EndIndex << endl;
|
||||
fflush(stdout);
|
||||
}
|
||||
#endif
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Processing message: u= " << u << " v= " << v << " Type= " << message_type << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
// Most of the time bundleSize == 3, thus, it's not worth parallelizing thi loop
|
||||
for (MilanLongInt bundleCounter = 3; bundleCounter < bundleSize + 3; bundleCounter += 3) {
|
||||
u = ReceiveBuffer[bundleCounter - 3]; // GHOST
|
||||
v = ReceiveBuffer[bundleCounter - 2]; // LOCAL
|
||||
message_type = ReceiveBuffer[bundleCounter - 1]; // TYPE
|
||||
|
||||
// CASE I: REQUEST
|
||||
if (message_type == REQUEST) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message type is REQUEST" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#ifdef DEBUG_GHOST_
|
||||
if ((v < 0) || (v < StartIndex) || ((v - StartIndex) > NLVer)) {
|
||||
cout << "\n(" << myRank << ") case 1 Bad address " << v << " " << StartIndex << " " << v - StartIndex << " " << NLVer << endl;
|
||||
fflush(stdout);
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
if (Mate[v - StartIndex] == -1) {
|
||||
// Process only if not already matched (v is local)
|
||||
candidateMate[NLVer + Ghost2LocalMap[u]] = v; // Set CandidateMate for the ghost
|
||||
if (candidateMate[v - StartIndex] == u) {
|
||||
GMate[Ghost2LocalMap[u]] = v; // u is ghost
|
||||
Mate[v - StartIndex] = u; // v is local
|
||||
U.push_back(v);
|
||||
U.push_back(u);
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << u << ") " << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S);
|
||||
} // End of if ( candidateMate[v-StartIndex] == u )e
|
||||
} // End of if ( Mate[v] == -1 )
|
||||
} // End of REQUEST
|
||||
else { // CASE II: SUCCESS
|
||||
if (message_type == SUCCESS) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message type is SUCCESS" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
GMate[Ghost2LocalMap[u]] = EndIndex + 1; // Set a Dummy Mate to make sure that we do not (u is a ghost) process it again
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S);
|
||||
#ifdef DEBUG_GHOST_
|
||||
if ((v < 0) || (v < StartIndex) || ((v - StartIndex) > NLVer)) {
|
||||
cout << "\n(" << myRank << ") case 2 Bad address " << v << " " << StartIndex << " " << v - StartIndex << " " << NLVer << endl;
|
||||
fflush(stdout);
|
||||
}
|
||||
#endif
|
||||
if (Mate[v - StartIndex] == -1) {
|
||||
// Process only if not already matched ( v is local)
|
||||
if (candidateMate[v - StartIndex] == u) {
|
||||
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
w = computeCandidateMateD(verLocPtr[v - StartIndex], verLocPtr[v - StartIndex + 1],
|
||||
edgeLocWeight, k,verLocInd, StartIndex, EndIndex,
|
||||
GMate, Mate, Ghost2LocalMap);
|
||||
candidateMate[v - StartIndex] = w;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")" << v << " Points to: " << w << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// If found a dominating edge:
|
||||
if (w >= 0) {
|
||||
if ((w < StartIndex) || (w > EndIndex)) {
|
||||
// w is a ghost
|
||||
// Build the Message Packet:
|
||||
Message[0] = v; // LOCAL
|
||||
Message[1] = w; // GHOST
|
||||
Message[2] = REQUEST; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a request message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
//assert(ghostOwner != -1);
|
||||
//assert(ghostOwner != myRank);
|
||||
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
|
||||
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
(*msgInd)++;
|
||||
(*msgActual)++;
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
|
||||
Mate[v - StartIndex] = w; // v is local
|
||||
GMate[Ghost2LocalMap[w]] = v; // w is ghost
|
||||
U.push_back(v);
|
||||
U.push_back(w);
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") " << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], S);
|
||||
} // End of if CandidateMate[w] = v
|
||||
} // End of if a Ghost Vertex
|
||||
else { // w is a local vertex
|
||||
if (candidateMate[w - StartIndex] == v) {
|
||||
Mate[v - StartIndex] = w; // v is local
|
||||
Mate[w - StartIndex] = v; // w is local
|
||||
// Q.push_back(u);
|
||||
U.push_back(v);
|
||||
U.push_back(w);
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") " << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} // End of if(CandidateMate(w) = v
|
||||
} // End of Else
|
||||
} // End of if(w >=0)
|
||||
else { // No dominant edge found
|
||||
adj11 = verLocPtr[v - StartIndex];
|
||||
adj12 = verLocPtr[v - StartIndex + 1];
|
||||
for (k1 = adj11; k1 < adj12; k1++) {
|
||||
w = verLocInd[k1];
|
||||
if ((w < StartIndex) || (w > EndIndex)) {
|
||||
// A ghost
|
||||
// Build the Message Packet:
|
||||
Message[0] = v; // LOCAL
|
||||
Message[1] = w; // GHOST
|
||||
Message[2] = FAILURE; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a failure message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
//assert(ghostOwner != -1);
|
||||
//assert(ghostOwner != myRank);
|
||||
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
|
||||
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
(*msgInd)++;
|
||||
(*msgActual)++;
|
||||
} // End of if(GHOST)
|
||||
} // End of for loop
|
||||
} // End of Else: w == -1
|
||||
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
} // End of if ( candidateMate[v-StartIndex] == u )
|
||||
} // End of if ( Mate[v] == -1 )
|
||||
} // End of if ( message_type == SUCCESS )
|
||||
else {
|
||||
// CASE III: FAILURE
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message type is FAILURE" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
GMate[Ghost2LocalMap[u]] = EndIndex + 1; // Set a Dummy Mate to make sure that we do not (u is a ghost) process this anymore
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S); // Decrease the counter
|
||||
} // End of else: CASE III
|
||||
} // End of else: CASE I
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
void processMessagesS(
|
||||
MilanLongInt NLVer,
|
||||
MilanLongInt *Mate,
|
||||
MilanLongInt *candidateMate,
|
||||
map<MilanLongInt, MilanLongInt> &Ghost2LocalMap,
|
||||
vector<MilanLongInt> &GMate,
|
||||
vector<MilanLongInt> &Counter,
|
||||
MilanLongInt StartIndex,
|
||||
MilanLongInt EndIndex,
|
||||
MilanLongInt *myCard,
|
||||
MilanLongInt *msgInd,
|
||||
MilanLongInt *msgActual,
|
||||
MilanFloat *edgeLocWeight,
|
||||
MilanLongInt *verDistance,
|
||||
MilanLongInt *verLocPtr,
|
||||
MilanLongInt k,
|
||||
MilanLongInt *verLocInd,
|
||||
MilanInt numProcs,
|
||||
MilanInt myRank,
|
||||
MPI_Comm comm,
|
||||
vector<MilanLongInt> &Message,
|
||||
MilanLongInt numGhostEdges,
|
||||
MilanLongInt u,
|
||||
MilanLongInt v,
|
||||
MilanLongInt *S,
|
||||
vector<MilanLongInt> &U)
|
||||
{
|
||||
|
||||
//#define PRINT_DEBUG_INFO_
|
||||
|
||||
MilanInt Sender;
|
||||
MPI_Status computeStatus;
|
||||
MilanLongInt bundleSize, w;
|
||||
MilanLongInt adj11, adj12, k1;
|
||||
MilanLongInt ghostOwner;
|
||||
int error_codeC;
|
||||
error_codeC = MPI_Comm_set_errhandler(MPI_COMM_WORLD, MPI_ERRORS_RETURN);
|
||||
char error_message[MPI_MAX_ERROR_STRING];
|
||||
int message_length;
|
||||
MilanLongInt message_type = 0;
|
||||
|
||||
// Buffer to receive bundled messages
|
||||
// Maximum messages that can be received from any processor is
|
||||
// twice the edge cut: REQUEST; REQUEST+(FAILURE/SUCCESS)
|
||||
vector<MilanLongInt> ReceiveBuffer;
|
||||
try
|
||||
{
|
||||
ReceiveBuffer.reserve(numGhostEdges * 2 * 3); // Three integers per cross edge
|
||||
}
|
||||
catch (length_error)
|
||||
{
|
||||
cout << "Error in function algoDistEdgeApproxDominatingEdgesMessageBundling: \n";
|
||||
cout << "Not enough memory to allocate the internal variables \n";
|
||||
exit(1);
|
||||
}
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout
|
||||
<< "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")About to begin Message processing phase ... *S=" << *S << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << "=========================************===============================" << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// BLOCKING RECEIVE:
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << " Waiting for blocking receive..." << endl;
|
||||
fflush(stdout);
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
//cout << myRank<<" Receiving ...";
|
||||
error_codeC = MPI_Recv(&Message[0], 3, TypeMap<MilanLongInt>(), MPI_ANY_SOURCE, ComputeTag, comm, &computeStatus);
|
||||
if (error_codeC != MPI_SUCCESS)
|
||||
{
|
||||
MPI_Error_string(error_codeC, error_message, &message_length);
|
||||
cout << "\n*Error in call to MPI_Receive on Slave: " << error_message << "\n";
|
||||
fflush(stdout);
|
||||
}
|
||||
Sender = computeStatus.MPI_SOURCE;
|
||||
//cout << " ...from "<<Sender << endl;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Received message from Process " << Sender << " Type= " << Message[2] << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
if (Message[2] == SIZEINFO) {
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Received bundled message from Process " << Sender << " Size= " << Message[0] << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
bundleSize = Message[0]; //#of integers in the message
|
||||
// Build the Message Buffer:
|
||||
if (!ReceiveBuffer.empty())
|
||||
ReceiveBuffer.clear(); // Empty it out first
|
||||
ReceiveBuffer.resize(bundleSize, -1); // Initialize
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message Bundle Before: " << endl;
|
||||
for (int i = 0; i < bundleSize; i++)
|
||||
cout << ReceiveBuffer[i] << ",";
|
||||
cout << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Receive the message
|
||||
//cout << myRank<<" Receiving from "<<Sender<<endl;
|
||||
error_codeC = MPI_Recv(&ReceiveBuffer[0], bundleSize, TypeMap<MilanLongInt>(), Sender, BundleTag, comm, &computeStatus);
|
||||
if (error_codeC != MPI_SUCCESS) {
|
||||
MPI_Error_string(error_codeC, error_message, &message_length);
|
||||
cout << "\n*Error in call to MPI_Receive on processor " << myRank << " Error: " << error_message << "\n";
|
||||
fflush(stdout);
|
||||
}
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message Bundle After: " << endl;
|
||||
for (int i = 0; i < bundleSize; i++)
|
||||
cout << ReceiveBuffer[i] << ",";
|
||||
cout << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} else { // Just a single message:
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Received regular message from Process " << Sender << " u= " << Message[0] << " v= " << Message[1] << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// Add the current message to Queue:
|
||||
bundleSize = 3; //#of integers in the message
|
||||
// Build the Message Buffer:
|
||||
if (!ReceiveBuffer.empty())
|
||||
ReceiveBuffer.clear(); // Empty it out first
|
||||
ReceiveBuffer.resize(bundleSize, -1); // Initialize
|
||||
|
||||
ReceiveBuffer[0] = Message[0]; // u
|
||||
ReceiveBuffer[1] = Message[1]; // v
|
||||
ReceiveBuffer[2] = Message[2]; // message_type
|
||||
}
|
||||
|
||||
#ifdef DEBUG_GHOST_
|
||||
if ((v < StartIndex) || (v > EndIndex)) {
|
||||
cout << "\n(" << myRank << ") From ReceiveBuffer: This should not happen: u= " << u << " v= " << v << " Type= " << message_type << " StartIndex " << StartIndex << " EndIndex " << EndIndex << endl;
|
||||
fflush(stdout);
|
||||
}
|
||||
#endif
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Processing message: u= " << u << " v= " << v << " Type= " << message_type << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
// Most of the time bundleSize == 3, thus, it's not worth parallelizing thi loop
|
||||
for (MilanLongInt bundleCounter = 3; bundleCounter < bundleSize + 3; bundleCounter += 3) {
|
||||
u = ReceiveBuffer[bundleCounter - 3]; // GHOST
|
||||
v = ReceiveBuffer[bundleCounter - 2]; // LOCAL
|
||||
message_type = ReceiveBuffer[bundleCounter - 1]; // TYPE
|
||||
|
||||
// CASE I: REQUEST
|
||||
if (message_type == REQUEST) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message type is REQUEST" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
#ifdef DEBUG_GHOST_
|
||||
if ((v < 0) || (v < StartIndex) || ((v - StartIndex) > NLVer)) {
|
||||
cout << "\n(" << myRank << ") case 1 Bad address " << v << " " << StartIndex << " " << v - StartIndex << " " << NLVer << endl;
|
||||
fflush(stdout);
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
if (Mate[v - StartIndex] == -1) {
|
||||
// Process only if not already matched (v is local)
|
||||
candidateMate[NLVer + Ghost2LocalMap[u]] = v; // Set CandidateMate for the ghost
|
||||
if (candidateMate[v - StartIndex] == u) {
|
||||
GMate[Ghost2LocalMap[u]] = v; // u is ghost
|
||||
Mate[v - StartIndex] = u; // v is local
|
||||
U.push_back(v);
|
||||
U.push_back(u);
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << u << ") " << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S);
|
||||
} // End of if ( candidateMate[v-StartIndex] == u )e
|
||||
} // End of if ( Mate[v] == -1 )
|
||||
} // End of REQUEST
|
||||
else { // CASE II: SUCCESS
|
||||
if (message_type == SUCCESS) {
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message type is SUCCESS" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
GMate[Ghost2LocalMap[u]] = EndIndex + 1; // Set a Dummy Mate to make sure that we do not (u is a ghost) process it again
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S);
|
||||
#ifdef DEBUG_GHOST_
|
||||
if ((v < 0) || (v < StartIndex) || ((v - StartIndex) > NLVer)) {
|
||||
cout << "\n(" << myRank << ") case 2 Bad address " << v << " " << StartIndex << " " << v - StartIndex << " " << NLVer << endl;
|
||||
fflush(stdout);
|
||||
}
|
||||
#endif
|
||||
if (Mate[v - StartIndex] == -1) {
|
||||
// Process only if not already matched ( v is local)
|
||||
if (candidateMate[v - StartIndex] == u) {
|
||||
// Start: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
w = computeCandidateMateS(verLocPtr[v - StartIndex], verLocPtr[v - StartIndex + 1],
|
||||
edgeLocWeight, k,verLocInd, StartIndex, EndIndex,
|
||||
GMate, Mate, Ghost2LocalMap);
|
||||
candidateMate[v - StartIndex] = w;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")" << v << " Points to: " << w << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
// If found a dominating edge:
|
||||
if (w >= 0) {
|
||||
if ((w < StartIndex) || (w > EndIndex)) {
|
||||
// w is a ghost
|
||||
// Build the Message Packet:
|
||||
Message[0] = v; // LOCAL
|
||||
Message[1] = w; // GHOST
|
||||
Message[2] = REQUEST; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a request message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
//assert(ghostOwner != -1);
|
||||
//assert(ghostOwner != myRank);
|
||||
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
|
||||
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
(*msgInd)++;
|
||||
(*msgActual)++;
|
||||
if (candidateMate[NLVer + Ghost2LocalMap[w]] == v) {
|
||||
Mate[v - StartIndex] = w; // v is local
|
||||
GMate[Ghost2LocalMap[w]] = v; // w is ghost
|
||||
U.push_back(v);
|
||||
U.push_back(w);
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") " << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[w]], S);
|
||||
} // End of if CandidateMate[w] = v
|
||||
} // End of if a Ghost Vertex
|
||||
else { // w is a local vertex
|
||||
if (candidateMate[w - StartIndex] == v) {
|
||||
Mate[v - StartIndex] = w; // v is local
|
||||
Mate[w - StartIndex] = v; // w is local
|
||||
// Q.push_back(u);
|
||||
U.push_back(v);
|
||||
U.push_back(w);
|
||||
(*myCard)++;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")MATCH: (" << v << "," << w << ") " << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
} // End of if(CandidateMate(w) = v
|
||||
} // End of Else
|
||||
} // End of if(w >=0)
|
||||
else { // No dominant edge found
|
||||
adj11 = verLocPtr[v - StartIndex];
|
||||
adj12 = verLocPtr[v - StartIndex + 1];
|
||||
for (k1 = adj11; k1 < adj12; k1++) {
|
||||
w = verLocInd[k1];
|
||||
if ((w < StartIndex) || (w > EndIndex)) {
|
||||
// A ghost
|
||||
// Build the Message Packet:
|
||||
Message[0] = v; // LOCAL
|
||||
Message[1] = w; // GHOST
|
||||
Message[2] = FAILURE; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending a failure message: ";
|
||||
cout << "\n(" << myRank << ")Ghost is " << w << " Owner is: " << findOwnerOfGhost(w, verDistance, myRank, numProcs) << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
ghostOwner = findOwnerOfGhost(w, verDistance, myRank, numProcs);
|
||||
//assert(ghostOwner != -1);
|
||||
//assert(ghostOwner != myRank);
|
||||
//cout << myRank<<" Sending to "<<ghostOwner<<endl;
|
||||
MPI_Bsend(&Message[0], 3, TypeMap<MilanLongInt>(), ghostOwner, ComputeTag, comm);
|
||||
(*msgInd)++;
|
||||
(*msgActual)++;
|
||||
} // End of if(GHOST)
|
||||
} // End of for loop
|
||||
} // End of Else: w == -1
|
||||
// End: PARALLEL_PROCESS_EXPOSED_VERTEX_B(v)
|
||||
} // End of if ( candidateMate[v-StartIndex] == u )
|
||||
} // End of if ( Mate[v] == -1 )
|
||||
} // End of if ( message_type == SUCCESS )
|
||||
else {
|
||||
// CASE III: FAILURE
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Message type is FAILURE" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
GMate[Ghost2LocalMap[u]] = EndIndex + 1; // Set a Dummy Mate to make sure that we do not (u is a ghost) process this anymore
|
||||
PROCESS_CROSS_EDGE(&Counter[Ghost2LocalMap[u]], S); // Decrease the counter
|
||||
} // End of else: CASE III
|
||||
} // End of else: CASE I
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
@@ -0,0 +1,32 @@
|
||||
#include "MatchBoxPC.h"
|
||||
void queuesTransfer(vector<MilanLongInt> &U,
|
||||
vector<MilanLongInt> &privateU,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MilanLongInt> &privateQLocalVtx,
|
||||
vector<MilanLongInt> &privateQGhostVtx,
|
||||
vector<MilanLongInt> &privateQMsgType,
|
||||
vector<MilanInt> &privateQOwner)
|
||||
{
|
||||
|
||||
#pragma omp critical(U)
|
||||
{
|
||||
U.insert(U.end(), privateU.begin(), privateU.end());
|
||||
|
||||
//#pragma omp critical(sendMessageTransfer)
|
||||
//{
|
||||
QLocalVtx.insert(QLocalVtx.end(), privateQLocalVtx.begin(), privateQLocalVtx.end());
|
||||
QGhostVtx.insert(QGhostVtx.end(), privateQGhostVtx.begin(), privateQGhostVtx.end());
|
||||
QMsgType.insert(QMsgType.end(), privateQMsgType.begin(), privateQMsgType.end());
|
||||
QOwner.insert(QOwner.end(), privateQOwner.begin(), privateQOwner.end());
|
||||
}
|
||||
|
||||
privateU.clear();
|
||||
privateQLocalVtx.clear();
|
||||
privateQGhostVtx.clear();
|
||||
privateQMsgType.clear();
|
||||
privateQOwner.clear();
|
||||
|
||||
}
|
||||
@@ -0,0 +1,208 @@
|
||||
#include "MatchBoxPC.h"
|
||||
void sendBundledMessages(MilanLongInt *numGhostEdges,
|
||||
MilanInt *BufferSize,
|
||||
MilanLongInt *Buffer,
|
||||
vector<MilanLongInt> &PCumulative,
|
||||
vector<MilanLongInt> &PMessageBundle,
|
||||
vector<MilanLongInt> &PSizeInfoMessages,
|
||||
MilanLongInt *PCounter,
|
||||
MilanLongInt NumMessagesBundled,
|
||||
MilanLongInt *msgActual,
|
||||
MilanLongInt *msgInd,
|
||||
MilanInt numProcs,
|
||||
MilanInt myRank,
|
||||
MPI_Comm comm,
|
||||
vector<MilanLongInt> &QLocalVtx,
|
||||
vector<MilanLongInt> &QGhostVtx,
|
||||
vector<MilanLongInt> &QMsgType,
|
||||
vector<MilanInt> &QOwner,
|
||||
vector<MPI_Request> &SRequest,
|
||||
vector<MPI_Status> &SStatus)
|
||||
{
|
||||
|
||||
MilanLongInt myIndex = 0, numMessagesToSend;
|
||||
MilanInt i = 0, OneMessageSize = 0;
|
||||
|
||||
#ifdef DEBUG_HANG_
|
||||
if (myRank == 0)
|
||||
cout << "\n(" << myRank << ") Send Bundles" << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
#pragma omp parallel private(i) default(shared) num_threads(NUM_THREAD)
|
||||
{
|
||||
#pragma omp master
|
||||
{
|
||||
// Data structures for Bundled Messages:
|
||||
#pragma omp task depend(inout \
|
||||
: PCumulative, PMessageBundle, PSizeInfoMessages) depend(in \
|
||||
: NumMessagesBundled, numProcs)
|
||||
{
|
||||
try {
|
||||
PMessageBundle.reserve(NumMessagesBundled * 3); // Three integers per message
|
||||
PCumulative.reserve(numProcs + 1); // Similar to Row Pointer vector in CSR data structure
|
||||
PSizeInfoMessages.reserve(numProcs * 3); // Buffer to hold the Size info message packets
|
||||
}
|
||||
catch (length_error)
|
||||
{
|
||||
cout << "Error in function algoDistEdgeApproxDominatingEdgesMessageBundling: \n";
|
||||
cout << "Not enough memory to allocate the internal variables \n";
|
||||
exit(1);
|
||||
}
|
||||
PMessageBundle.resize(NumMessagesBundled * 3, -1); // Initialize
|
||||
PCumulative.resize(numProcs + 1, 0); // Only initialize the counter variable
|
||||
PSizeInfoMessages.resize(numProcs * 3, 0);
|
||||
}
|
||||
|
||||
#pragma omp task depend(inout \
|
||||
: PCumulative) depend(in \
|
||||
: PCounter)
|
||||
{
|
||||
for (i = 0; i < numProcs; i++)
|
||||
PCumulative[i + 1] = PCumulative[i] + PCounter[i];
|
||||
}
|
||||
|
||||
#pragma omp task depend(inout \
|
||||
: PCounter)
|
||||
{
|
||||
// Reuse PCounter to keep track of how many messages were inserted:
|
||||
for (MilanInt i = 0; i < numProcs; i++) // Changed by Fabio to be an integer, addresses needs to be integers!
|
||||
PCounter[i] = 0;
|
||||
}
|
||||
|
||||
// Build the Message Bundle packet:
|
||||
#pragma omp task depend(in \
|
||||
: PCounter, QLocalVtx, QGhostVtx, QMsgType, QOwner, PMessageBundle, PCumulative) depend(out \
|
||||
: myIndex, PMessageBundle, PCounter)
|
||||
{
|
||||
for (i = 0; i < NumMessagesBundled; i++) {
|
||||
myIndex = (PCumulative[QOwner[i]] + PCounter[QOwner[i]]) * 3;
|
||||
PMessageBundle[myIndex + 0] = QLocalVtx[i];
|
||||
PMessageBundle[myIndex + 1] = QGhostVtx[i];
|
||||
PMessageBundle[myIndex + 2] = QMsgType[i];
|
||||
PCounter[QOwner[i]]++;
|
||||
}
|
||||
}
|
||||
|
||||
// Send the Bundled Messages: Use ISend
|
||||
#pragma omp task depend(out \
|
||||
: SRequest, SStatus)
|
||||
{
|
||||
try
|
||||
{
|
||||
SRequest.reserve(numProcs * 2); // At most two messages per processor
|
||||
SStatus.reserve(numProcs * 2); // At most two messages per processor
|
||||
}
|
||||
catch (length_error)
|
||||
{
|
||||
cout << "Error in function algoDistEdgeApproxDominatingEdgesLinearSearchImmediateSend: \n";
|
||||
cout << "Not enough memory to allocate the internal variables \n";
|
||||
exit(1);
|
||||
}
|
||||
}
|
||||
|
||||
// Send the Messages
|
||||
#pragma omp task depend(inout \
|
||||
: SRequest, PSizeInfoMessages, PCumulative) depend(out \
|
||||
: *msgActual, *msgInd)
|
||||
{
|
||||
for (i = 0; i < numProcs; i++) { // Changed by Fabio to be an integer, addresses needs to be integers!
|
||||
if (i == myRank) // Do not send anything to yourself
|
||||
continue;
|
||||
// Send the Message with information about the size of next message:
|
||||
// Build the Message Packet:
|
||||
PSizeInfoMessages[i * 3 + 0] = (PCumulative[i + 1] - PCumulative[i]) * 3; // # of integers in the next message
|
||||
PSizeInfoMessages[i * 3 + 1] = -1; // Dummy packet
|
||||
PSizeInfoMessages[i * 3 + 2] = SIZEINFO; // TYPE
|
||||
// Send a Request (Asynchronous)
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Sending bundled message to process " << i << " size: " << PSizeInfoMessages[i * 3 + 0] << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
if (PSizeInfoMessages[i * 3 + 0] > 0)
|
||||
{ // Send only if it is a nonempty packet
|
||||
MPI_Isend(&PSizeInfoMessages[i * 3 + 0], 3, TypeMap<MilanLongInt>(), i, ComputeTag, comm,
|
||||
&SRequest[(*msgInd)]);
|
||||
(*msgActual)++;
|
||||
(*msgInd)++;
|
||||
// Now Send the message with the data packet:
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")SendiFFng Bundle to : " << i << endl;
|
||||
for (k = (PCumulative[i] * 3); k < (PCumulative[i] * 3 + PSizeInfoMessages[i * 3 + 0]); k++)
|
||||
cout << PMessageBundle[k] << ",";
|
||||
cout << endl;
|
||||
fflush(stdout);
|
||||
#endif
|
||||
MPI_Isend(&PMessageBundle[PCumulative[i] * 3], PSizeInfoMessages[i * 3 + 0],
|
||||
TypeMap<MilanLongInt>(), i, BundleTag, comm, &SRequest[(*msgInd)]);
|
||||
(*msgInd)++;
|
||||
} // End of if size > 0
|
||||
}
|
||||
}
|
||||
|
||||
#pragma omp task depend(inout \
|
||||
: PCumulative, QLocalVtx, QGhostVtx, QMsgType, QOwner)
|
||||
{
|
||||
|
||||
// Free up temporary memory:
|
||||
PCumulative.clear();
|
||||
QLocalVtx.clear();
|
||||
QGhostVtx.clear();
|
||||
QMsgType.clear();
|
||||
QOwner.clear();
|
||||
}
|
||||
|
||||
#pragma omp task depend(inout : OneMessageSize, *BufferSize) depend(out : numMessagesToSend) depend(in : *numGhostEdges)
|
||||
{
|
||||
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Number of Ghost edges = " << *numGhostEdges;
|
||||
cout << "\n(" << myRank << ")Total number of potential message X 2 = " << *numGhostEdges * 2;
|
||||
cout << "\n(" << myRank << ")Number messages already sent in bundles = " << NumMessagesBundled;
|
||||
if (*numGhostEdges > 0)
|
||||
{
|
||||
cout << "\n(" << myRank << ")Percentage of total = " << ((double)NumMessagesBundled / (double)(*numGhostEdges * 2)) * 100.0 << "% \n";
|
||||
}
|
||||
fflush(stdout);
|
||||
#endif
|
||||
|
||||
// Allocate memory for MPI Send messages:
|
||||
/* WILL COME BACK HERE - NO NEED TO STORE ALL THIS MEMORY !! */
|
||||
OneMessageSize = 0;
|
||||
MPI_Pack_size(3, TypeMap<MilanLongInt>(), comm, &OneMessageSize); // Size of one message packet
|
||||
// How many messages to send?
|
||||
// Potentially three kinds of messages will be sent/received:
|
||||
// Request, Success, Failure.
|
||||
// But only two will be sent from a given processor.
|
||||
// Substract the number of messages that have already been sent as bundled messages:
|
||||
numMessagesToSend = (*numGhostEdges) * 2 - NumMessagesBundled;
|
||||
*BufferSize = (OneMessageSize + MPI_BSEND_OVERHEAD) * numMessagesToSend;
|
||||
}
|
||||
|
||||
#pragma omp task depend(out : Buffer) depend(in : *BufferSize)
|
||||
{
|
||||
Buffer = 0;
|
||||
#ifdef PRINT_DEBUG_INFO_
|
||||
cout << "\n(" << myRank << ")Size of One Message from PACK= " << OneMessageSize;
|
||||
cout << "\n(" << myRank << ")Size of Message overhead = " << MPI_BSEND_OVERHEAD;
|
||||
cout << "\n(" << myRank << ")Number of Ghost edges = " << *numGhostEdges;
|
||||
cout << "\n(" << myRank << ")Number of remaining message = " << numMessagesToSend;
|
||||
cout << "\n(" << myRank << ")BufferSize = " << (*BufferSize);
|
||||
cout << "\n(" << myRank << ")Attaching Buffer on.. ";
|
||||
fflush(stdout);
|
||||
#endif
|
||||
if ((*BufferSize) > 0)
|
||||
{
|
||||
Buffer = (MilanLongInt *)malloc((*BufferSize)); // Allocate memory
|
||||
if (Buffer == 0)
|
||||
{
|
||||
cout << "Error in function algoDistEdgeApproxDominatingEdgesLinearSearch: \n";
|
||||
cout << "Not enough memory to allocate for send buffer on process " << myRank << "\n";
|
||||
exit(1);
|
||||
}
|
||||
MPI_Buffer_attach(Buffer, *BufferSize); // Attach the Buffer
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
@@ -507,6 +507,71 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info)
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3)
|
||||
! gfortran 13.3.0 generates a strange error here with MOLD
|
||||
! moving to SOURCE but only for this version, since it's heavier
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(amg_c_onelev_type), intent(inout) :: level
|
||||
class(amg_c_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (allocated(save1)) then
|
||||
call save1%free(info)
|
||||
if (info == 0) deallocate(save1,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
call save2%free(info)
|
||||
if (info == 0) deallocate(save2,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
allocate(save1, source=level%sm,stat=info)
|
||||
if (info == 0) call level%sm%clone_settings(save1,info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) then
|
||||
allocate(save2, source=level%sm2a,stat=info)
|
||||
if (info == 0) call level%sm2a%clone_settings(save2,info)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine save_smoothers
|
||||
|
||||
subroutine restore_smoothers(level,save1, save2,info)
|
||||
type(amg_c_onelev_type), intent(inout), target :: level
|
||||
class(amg_c_base_smoother_type), allocatable, intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
|
||||
if (allocated(level%sm)) then
|
||||
if (info == 0) call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm,stat=info)
|
||||
end if
|
||||
if (allocated(save1)) then
|
||||
if (info == 0) allocate(level%sm,source=save1,stat=info)
|
||||
if (info == 0) call save1%clone_settings(level%sm,info)
|
||||
end if
|
||||
|
||||
if (info /= 0) return
|
||||
|
||||
if (allocated(level%sm2a)) then
|
||||
if (info == 0) call level%sm2a%free(info)
|
||||
if (info == 0) deallocate(level%sm2a,stat=info)
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
|
||||
if (info == 0) call save2%clone_settings(level%sm2a,info)
|
||||
if (info == 0) level%sm2 => level%sm2a
|
||||
else
|
||||
if (allocated(level%sm)) level%sm2 => level%sm
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine restore_smoothers
|
||||
|
||||
#else
|
||||
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(amg_c_onelev_type), intent(inout) :: level
|
||||
class(amg_c_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
@@ -565,5 +630,5 @@ contains
|
||||
|
||||
return
|
||||
end subroutine restore_smoothers
|
||||
|
||||
#endif
|
||||
end subroutine amg_c_hierarchy_bld
|
||||
@@ -186,8 +186,8 @@ subroutine amg_c_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& ' but it has been changed to distributed.'
|
||||
end if
|
||||
|
||||
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
|
||||
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
|
||||
case(amg_ilu_n_, amg_ilu_t_,amg_milu_n_)
|
||||
if (prec%precv(iszv)%sm%sv%get_id() /= amg_ilu_n_) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
|
||||
& amg_fact_names(coarse_solve_id)
|
||||
|
||||
@@ -84,6 +84,7 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
use amg_c_diag_solver
|
||||
use amg_c_l1_diag_solver
|
||||
use amg_c_ilu_solver
|
||||
use amg_c_jac_solver
|
||||
use amg_c_id_solver
|
||||
use amg_c_gs_solver
|
||||
use amg_c_ainv_solver
|
||||
@@ -193,6 +194,15 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
end if
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
|
||||
case('COARSE_INVFILL')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: Inconsistent specification of WHAT vs. ILEV'
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
|
||||
|
||||
case('BJAC_ITRACE')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -242,6 +252,11 @@ subroutine amg_ccprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_INVFILL')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('BJAC_ITRACE')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos)
|
||||
@@ -308,6 +323,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
use amg_c_diag_solver
|
||||
use amg_c_l1_diag_solver
|
||||
use amg_c_ilu_solver
|
||||
use amg_c_jac_solver
|
||||
use amg_c_id_solver
|
||||
use amg_c_gs_solver
|
||||
use amg_c_ainv_solver
|
||||
@@ -469,7 +485,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -483,7 +499,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -506,7 +522,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -514,21 +530,21 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#endif
|
||||
case('ILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('MILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
@@ -543,7 +559,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -566,7 +582,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -590,7 +606,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -698,7 +714,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -711,7 +727,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -734,7 +750,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -742,21 +758,21 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#endif
|
||||
case('ILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('MILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
@@ -771,7 +787,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -794,7 +810,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -818,7 +834,7 @@ subroutine amg_ccprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
|
||||
@@ -170,7 +170,7 @@ subroutine amg_cfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
call prec%precv(1)%sm%descr(info,iout=iout_,prefix=prefix)
|
||||
nswps = prec%precv(1)%parms%sweeps_pre
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Number of sweeps : ',nswps
|
||||
write(iout_,*) trim(prefix_), ' Number of sweeps/degree : ',nswps
|
||||
write(iout_,*) trim(prefix_)
|
||||
|
||||
else if (nlev > 1) then
|
||||
|
||||
@@ -0,0 +1,152 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_dfile_prec_memory_use.f90
|
||||
!
|
||||
!
|
||||
! Subroutine: amg_file_prec_memory_use
|
||||
! Version: complex
|
||||
!
|
||||
! This routine prints a memory_useiption of the preconditioner to the standard
|
||||
! output or to a file. It must be called after the preconditioner has been
|
||||
! built by amg_precbld.
|
||||
!
|
||||
! Arguments:
|
||||
! p - type(amg_Tprec_type), input.
|
||||
! The preconditioner data structure to be printed out.
|
||||
! info - integer, output.
|
||||
! error code.
|
||||
! iout - integer, input, optional.
|
||||
! The id of the file where the preconditioner description
|
||||
! will be printed. If iout is not present, then the standard
|
||||
! output is condidered.
|
||||
! root - integer, input, optional.
|
||||
! The id of the process printing the message; -1 acts as a wildcard.
|
||||
! Default is psb_root_
|
||||
!
|
||||
!
|
||||
!
|
||||
! verbosity:
|
||||
! <0: suppress all messages
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_cfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
|
||||
use psb_base_mod
|
||||
use amg_c_prec_mod, amg_protect_name => amg_cfile_prec_memory_use
|
||||
use amg_c_inner_mod
|
||||
use amg_c_gs_solver
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_cprec_type), intent(in) :: prec
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev, nlev, ilmin, nswps
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
logical :: is_symgs
|
||||
character(len=20), parameter :: name='amg_file_prec_memory_use'
|
||||
integer(psb_ipk_) :: iout_, root_, verbosity_
|
||||
logical :: global_
|
||||
character(1024) :: prefix_
|
||||
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
if (iout_ < 0) iout_ = psb_out_unit
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
|
||||
ctxt = prec%ctxt
|
||||
call psb_info(ctxt,me,np)
|
||||
prefix_ = ""
|
||||
if (verbosity_ == 0) then
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
end if
|
||||
else if (verbosity_ > 0) then
|
||||
if (present(prefix)) then
|
||||
write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
|
||||
else
|
||||
write(prefix_,'(a,i5,a)') 'Process ',me,': '
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
end if
|
||||
if (root_ == -1) root_ = me
|
||||
|
||||
if (allocated(prec%precv)) then
|
||||
if (verbosity_ >=0) then
|
||||
if (me == root_) then
|
||||
write(iout_,*)
|
||||
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
|
||||
end if
|
||||
nlev = size(prec%precv)
|
||||
do ilev=1,nlev
|
||||
call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
|
||||
& iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
|
||||
end do
|
||||
|
||||
else
|
||||
write(iout_,*) trim(name), &
|
||||
& ': Error: no base preconditioner available, something is wrong!'
|
||||
info = -2
|
||||
return
|
||||
endif
|
||||
end if
|
||||
9998 continue
|
||||
end subroutine amg_cfile_prec_memory_use
|
||||
@@ -98,6 +98,7 @@ subroutine amg_cprecinit(ctxt,prec,ptype,info)
|
||||
use amg_c_diag_solver
|
||||
use amg_c_ilu_solver
|
||||
use amg_c_gs_solver
|
||||
|
||||
#if defined(HAVE_SLU_)
|
||||
use amg_c_slu_solver
|
||||
#endif
|
||||
@@ -152,7 +153,6 @@ subroutine amg_cprecinit(ctxt,prec,ptype,info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(amg_c_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
|
||||
@@ -507,6 +507,71 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info)
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3)
|
||||
! gfortran 13.3.0 generates a strange error here with MOLD
|
||||
! moving to SOURCE but only for this version, since it's heavier
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(amg_d_onelev_type), intent(inout) :: level
|
||||
class(amg_d_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (allocated(save1)) then
|
||||
call save1%free(info)
|
||||
if (info == 0) deallocate(save1,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
call save2%free(info)
|
||||
if (info == 0) deallocate(save2,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
allocate(save1, source=level%sm,stat=info)
|
||||
if (info == 0) call level%sm%clone_settings(save1,info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) then
|
||||
allocate(save2, source=level%sm2a,stat=info)
|
||||
if (info == 0) call level%sm2a%clone_settings(save2,info)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine save_smoothers
|
||||
|
||||
subroutine restore_smoothers(level,save1, save2,info)
|
||||
type(amg_d_onelev_type), intent(inout), target :: level
|
||||
class(amg_d_base_smoother_type), allocatable, intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
|
||||
if (allocated(level%sm)) then
|
||||
if (info == 0) call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm,stat=info)
|
||||
end if
|
||||
if (allocated(save1)) then
|
||||
if (info == 0) allocate(level%sm,source=save1,stat=info)
|
||||
if (info == 0) call save1%clone_settings(level%sm,info)
|
||||
end if
|
||||
|
||||
if (info /= 0) return
|
||||
|
||||
if (allocated(level%sm2a)) then
|
||||
if (info == 0) call level%sm2a%free(info)
|
||||
if (info == 0) deallocate(level%sm2a,stat=info)
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
|
||||
if (info == 0) call save2%clone_settings(level%sm2a,info)
|
||||
if (info == 0) level%sm2 => level%sm2a
|
||||
else
|
||||
if (allocated(level%sm)) level%sm2 => level%sm
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine restore_smoothers
|
||||
|
||||
#else
|
||||
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(amg_d_onelev_type), intent(inout) :: level
|
||||
class(amg_d_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
@@ -565,5 +630,5 @@ contains
|
||||
|
||||
return
|
||||
end subroutine restore_smoothers
|
||||
|
||||
#endif
|
||||
end subroutine amg_d_hierarchy_bld
|
||||
@@ -186,8 +186,8 @@ subroutine amg_d_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& ' but it has been changed to distributed.'
|
||||
end if
|
||||
|
||||
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
|
||||
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
|
||||
case(amg_ilu_n_, amg_ilu_t_,amg_milu_n_)
|
||||
if (prec%precv(iszv)%sm%sv%get_id() /= amg_ilu_n_) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
|
||||
& amg_fact_names(coarse_solve_id)
|
||||
|
||||
@@ -84,6 +84,7 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
use amg_d_diag_solver
|
||||
use amg_d_l1_diag_solver
|
||||
use amg_d_ilu_solver
|
||||
use amg_d_jac_solver
|
||||
use amg_d_id_solver
|
||||
use amg_d_gs_solver
|
||||
use amg_d_ainv_solver
|
||||
@@ -199,6 +200,15 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
end if
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
|
||||
case('COARSE_INVFILL')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: Inconsistent specification of WHAT vs. ILEV'
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
|
||||
|
||||
case('BJAC_ITRACE')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -248,6 +258,11 @@ subroutine amg_dcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_INVFILL')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('BJAC_ITRACE')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos)
|
||||
@@ -314,6 +329,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
use amg_d_diag_solver
|
||||
use amg_d_l1_diag_solver
|
||||
use amg_d_ilu_solver
|
||||
use amg_d_jac_solver
|
||||
use amg_d_id_solver
|
||||
use amg_d_gs_solver
|
||||
use amg_d_ainv_solver
|
||||
@@ -483,7 +499,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -499,7 +515,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -522,7 +538,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -530,21 +546,21 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#endif
|
||||
case('ILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('MILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
@@ -559,7 +575,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -589,7 +605,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -627,7 +643,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -737,7 +753,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -752,7 +768,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -775,7 +791,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -783,21 +799,21 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#endif
|
||||
case('ILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('MILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
@@ -812,7 +828,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -842,7 +858,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -880,7 +896,7 @@ subroutine amg_dcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
|
||||
@@ -170,7 +170,7 @@ subroutine amg_dfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
call prec%precv(1)%sm%descr(info,iout=iout_,prefix=prefix)
|
||||
nswps = prec%precv(1)%parms%sweeps_pre
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Number of sweeps : ',nswps
|
||||
write(iout_,*) trim(prefix_), ' Number of sweeps/degree : ',nswps
|
||||
write(iout_,*) trim(prefix_)
|
||||
|
||||
else if (nlev > 1) then
|
||||
|
||||
@@ -0,0 +1,152 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_dfile_prec_memory_use.f90
|
||||
!
|
||||
!
|
||||
! Subroutine: amg_file_prec_memory_use
|
||||
! Version: real
|
||||
!
|
||||
! This routine prints a memory_useiption of the preconditioner to the standard
|
||||
! output or to a file. It must be called after the preconditioner has been
|
||||
! built by amg_precbld.
|
||||
!
|
||||
! Arguments:
|
||||
! p - type(amg_Tprec_type), input.
|
||||
! The preconditioner data structure to be printed out.
|
||||
! info - integer, output.
|
||||
! error code.
|
||||
! iout - integer, input, optional.
|
||||
! The id of the file where the preconditioner description
|
||||
! will be printed. If iout is not present, then the standard
|
||||
! output is condidered.
|
||||
! root - integer, input, optional.
|
||||
! The id of the process printing the message; -1 acts as a wildcard.
|
||||
! Default is psb_root_
|
||||
!
|
||||
!
|
||||
!
|
||||
! verbosity:
|
||||
! <0: suppress all messages
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_dfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
|
||||
use psb_base_mod
|
||||
use amg_d_prec_mod, amg_protect_name => amg_dfile_prec_memory_use
|
||||
use amg_d_inner_mod
|
||||
use amg_d_gs_solver
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_dprec_type), intent(in) :: prec
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev, nlev, ilmin, nswps
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
logical :: is_symgs
|
||||
character(len=20), parameter :: name='amg_file_prec_memory_use'
|
||||
integer(psb_ipk_) :: iout_, root_, verbosity_
|
||||
logical :: global_
|
||||
character(1024) :: prefix_
|
||||
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
if (iout_ < 0) iout_ = psb_out_unit
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
|
||||
ctxt = prec%ctxt
|
||||
call psb_info(ctxt,me,np)
|
||||
prefix_ = ""
|
||||
if (verbosity_ == 0) then
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
end if
|
||||
else if (verbosity_ > 0) then
|
||||
if (present(prefix)) then
|
||||
write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
|
||||
else
|
||||
write(prefix_,'(a,i5,a)') 'Process ',me,': '
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
end if
|
||||
if (root_ == -1) root_ = me
|
||||
|
||||
if (allocated(prec%precv)) then
|
||||
if (verbosity_ >=0) then
|
||||
if (me == root_) then
|
||||
write(iout_,*)
|
||||
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
|
||||
end if
|
||||
nlev = size(prec%precv)
|
||||
do ilev=1,nlev
|
||||
call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
|
||||
& iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
|
||||
end do
|
||||
|
||||
else
|
||||
write(iout_,*) trim(name), &
|
||||
& ': Error: no base preconditioner available, something is wrong!'
|
||||
info = -2
|
||||
return
|
||||
endif
|
||||
end if
|
||||
9998 continue
|
||||
end subroutine amg_dfile_prec_memory_use
|
||||
@@ -98,6 +98,8 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
|
||||
use amg_d_diag_solver
|
||||
use amg_d_ilu_solver
|
||||
use amg_d_gs_solver
|
||||
use amg_d_poly_smoother
|
||||
|
||||
#if defined(HAVE_UMF_)
|
||||
use amg_d_umf_solver
|
||||
#endif
|
||||
@@ -155,7 +157,14 @@ subroutine amg_dprecinit(ctxt,prec,ptype,info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(amg_d_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('POLY')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(amg_d_poly_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(amg_d_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
|
||||
@@ -507,6 +507,71 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info)
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3)
|
||||
! gfortran 13.3.0 generates a strange error here with MOLD
|
||||
! moving to SOURCE but only for this version, since it's heavier
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(amg_s_onelev_type), intent(inout) :: level
|
||||
class(amg_s_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (allocated(save1)) then
|
||||
call save1%free(info)
|
||||
if (info == 0) deallocate(save1,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
call save2%free(info)
|
||||
if (info == 0) deallocate(save2,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
allocate(save1, source=level%sm,stat=info)
|
||||
if (info == 0) call level%sm%clone_settings(save1,info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) then
|
||||
allocate(save2, source=level%sm2a,stat=info)
|
||||
if (info == 0) call level%sm2a%clone_settings(save2,info)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine save_smoothers
|
||||
|
||||
subroutine restore_smoothers(level,save1, save2,info)
|
||||
type(amg_s_onelev_type), intent(inout), target :: level
|
||||
class(amg_s_base_smoother_type), allocatable, intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
|
||||
if (allocated(level%sm)) then
|
||||
if (info == 0) call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm,stat=info)
|
||||
end if
|
||||
if (allocated(save1)) then
|
||||
if (info == 0) allocate(level%sm,source=save1,stat=info)
|
||||
if (info == 0) call save1%clone_settings(level%sm,info)
|
||||
end if
|
||||
|
||||
if (info /= 0) return
|
||||
|
||||
if (allocated(level%sm2a)) then
|
||||
if (info == 0) call level%sm2a%free(info)
|
||||
if (info == 0) deallocate(level%sm2a,stat=info)
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
|
||||
if (info == 0) call save2%clone_settings(level%sm2a,info)
|
||||
if (info == 0) level%sm2 => level%sm2a
|
||||
else
|
||||
if (allocated(level%sm)) level%sm2 => level%sm
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine restore_smoothers
|
||||
|
||||
#else
|
||||
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(amg_s_onelev_type), intent(inout) :: level
|
||||
class(amg_s_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
@@ -565,5 +630,5 @@ contains
|
||||
|
||||
return
|
||||
end subroutine restore_smoothers
|
||||
|
||||
#endif
|
||||
end subroutine amg_s_hierarchy_bld
|
||||
@@ -186,8 +186,8 @@ subroutine amg_s_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& ' but it has been changed to distributed.'
|
||||
end if
|
||||
|
||||
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
|
||||
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
|
||||
case(amg_ilu_n_, amg_ilu_t_,amg_milu_n_)
|
||||
if (prec%precv(iszv)%sm%sv%get_id() /= amg_ilu_n_) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
|
||||
& amg_fact_names(coarse_solve_id)
|
||||
|
||||
@@ -84,6 +84,7 @@ subroutine amg_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
use amg_s_diag_solver
|
||||
use amg_s_l1_diag_solver
|
||||
use amg_s_ilu_solver
|
||||
use amg_s_jac_solver
|
||||
use amg_s_id_solver
|
||||
use amg_s_gs_solver
|
||||
use amg_s_ainv_solver
|
||||
@@ -193,6 +194,15 @@ subroutine amg_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
end if
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
|
||||
case('COARSE_INVFILL')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: Inconsistent specification of WHAT vs. ILEV'
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
|
||||
|
||||
case('BJAC_ITRACE')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -242,6 +252,11 @@ subroutine amg_scprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_INVFILL')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('BJAC_ITRACE')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos)
|
||||
@@ -308,6 +323,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
use amg_s_diag_solver
|
||||
use amg_s_l1_diag_solver
|
||||
use amg_s_ilu_solver
|
||||
use amg_s_jac_solver
|
||||
use amg_s_id_solver
|
||||
use amg_s_gs_solver
|
||||
use amg_s_ainv_solver
|
||||
@@ -469,7 +485,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -483,7 +499,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -506,7 +522,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -514,21 +530,21 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#endif
|
||||
case('ILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('MILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
@@ -543,7 +559,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -566,7 +582,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -590,7 +606,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -698,7 +714,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -711,7 +727,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -734,7 +750,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -742,21 +758,21 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#endif
|
||||
case('ILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('MILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
@@ -771,7 +787,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -794,7 +810,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -818,7 +834,7 @@ subroutine amg_scprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
|
||||
@@ -170,7 +170,7 @@ subroutine amg_sfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
call prec%precv(1)%sm%descr(info,iout=iout_,prefix=prefix)
|
||||
nswps = prec%precv(1)%parms%sweeps_pre
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Number of sweeps : ',nswps
|
||||
write(iout_,*) trim(prefix_), ' Number of sweeps/degree : ',nswps
|
||||
write(iout_,*) trim(prefix_)
|
||||
|
||||
else if (nlev > 1) then
|
||||
|
||||
@@ -0,0 +1,152 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_dfile_prec_memory_use.f90
|
||||
!
|
||||
!
|
||||
! Subroutine: amg_file_prec_memory_use
|
||||
! Version: real
|
||||
!
|
||||
! This routine prints a memory_useiption of the preconditioner to the standard
|
||||
! output or to a file. It must be called after the preconditioner has been
|
||||
! built by amg_precbld.
|
||||
!
|
||||
! Arguments:
|
||||
! p - type(amg_Tprec_type), input.
|
||||
! The preconditioner data structure to be printed out.
|
||||
! info - integer, output.
|
||||
! error code.
|
||||
! iout - integer, input, optional.
|
||||
! The id of the file where the preconditioner description
|
||||
! will be printed. If iout is not present, then the standard
|
||||
! output is condidered.
|
||||
! root - integer, input, optional.
|
||||
! The id of the process printing the message; -1 acts as a wildcard.
|
||||
! Default is psb_root_
|
||||
!
|
||||
!
|
||||
!
|
||||
! verbosity:
|
||||
! <0: suppress all messages
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_sfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
|
||||
use psb_base_mod
|
||||
use amg_s_prec_mod, amg_protect_name => amg_sfile_prec_memory_use
|
||||
use amg_s_inner_mod
|
||||
use amg_s_gs_solver
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_sprec_type), intent(in) :: prec
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev, nlev, ilmin, nswps
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
logical :: is_symgs
|
||||
character(len=20), parameter :: name='amg_file_prec_memory_use'
|
||||
integer(psb_ipk_) :: iout_, root_, verbosity_
|
||||
logical :: global_
|
||||
character(1024) :: prefix_
|
||||
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
if (iout_ < 0) iout_ = psb_out_unit
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
|
||||
ctxt = prec%ctxt
|
||||
call psb_info(ctxt,me,np)
|
||||
prefix_ = ""
|
||||
if (verbosity_ == 0) then
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
end if
|
||||
else if (verbosity_ > 0) then
|
||||
if (present(prefix)) then
|
||||
write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
|
||||
else
|
||||
write(prefix_,'(a,i5,a)') 'Process ',me,': '
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
end if
|
||||
if (root_ == -1) root_ = me
|
||||
|
||||
if (allocated(prec%precv)) then
|
||||
if (verbosity_ >=0) then
|
||||
if (me == root_) then
|
||||
write(iout_,*)
|
||||
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
|
||||
end if
|
||||
nlev = size(prec%precv)
|
||||
do ilev=1,nlev
|
||||
call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
|
||||
& iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
|
||||
end do
|
||||
|
||||
else
|
||||
write(iout_,*) trim(name), &
|
||||
& ': Error: no base preconditioner available, something is wrong!'
|
||||
info = -2
|
||||
return
|
||||
endif
|
||||
end if
|
||||
9998 continue
|
||||
end subroutine amg_sfile_prec_memory_use
|
||||
@@ -98,6 +98,8 @@ subroutine amg_sprecinit(ctxt,prec,ptype,info)
|
||||
use amg_s_diag_solver
|
||||
use amg_s_ilu_solver
|
||||
use amg_s_gs_solver
|
||||
use amg_s_poly_smoother
|
||||
|
||||
#if defined(HAVE_SLU_)
|
||||
use amg_s_slu_solver
|
||||
#endif
|
||||
@@ -152,7 +154,14 @@ subroutine amg_sprecinit(ctxt,prec,ptype,info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(amg_s_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('POLY')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
allocate(prec%precv(nlev_),stat=info)
|
||||
allocate(amg_s_poly_smoother_type :: prec%precv(ilev_)%sm, stat=info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(amg_s_l1_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
|
||||
@@ -507,6 +507,71 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info)
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
#if ( __GNUC__ == 13 && __GNUC_MINOR__ == 3)
|
||||
! gfortran 13.3.0 generates a strange error here with MOLD
|
||||
! moving to SOURCE but only for this version, since it's heavier
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(amg_z_onelev_type), intent(inout) :: level
|
||||
class(amg_z_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
if (allocated(save1)) then
|
||||
call save1%free(info)
|
||||
if (info == 0) deallocate(save1,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
call save2%free(info)
|
||||
if (info == 0) deallocate(save2,stat=info)
|
||||
if (info /= 0) return
|
||||
end if
|
||||
allocate(save1, source=level%sm,stat=info)
|
||||
if (info == 0) call level%sm%clone_settings(save1,info)
|
||||
if ((info == 0).and.allocated(level%sm2a)) then
|
||||
allocate(save2, source=level%sm2a,stat=info)
|
||||
if (info == 0) call level%sm2a%clone_settings(save2,info)
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine save_smoothers
|
||||
|
||||
subroutine restore_smoothers(level,save1, save2,info)
|
||||
type(amg_z_onelev_type), intent(inout), target :: level
|
||||
class(amg_z_base_smoother_type), allocatable, intent(inout) :: save1, save2
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
|
||||
info = 0
|
||||
|
||||
if (allocated(level%sm)) then
|
||||
if (info == 0) call level%sm%free(info)
|
||||
if (info == 0) deallocate(level%sm,stat=info)
|
||||
end if
|
||||
if (allocated(save1)) then
|
||||
if (info == 0) allocate(level%sm,source=save1,stat=info)
|
||||
if (info == 0) call save1%clone_settings(level%sm,info)
|
||||
end if
|
||||
|
||||
if (info /= 0) return
|
||||
|
||||
if (allocated(level%sm2a)) then
|
||||
if (info == 0) call level%sm2a%free(info)
|
||||
if (info == 0) deallocate(level%sm2a,stat=info)
|
||||
end if
|
||||
if (allocated(save2)) then
|
||||
if (info == 0) allocate(level%sm2a,source=save2,stat=info)
|
||||
if (info == 0) call save2%clone_settings(level%sm2a,info)
|
||||
if (info == 0) level%sm2 => level%sm2a
|
||||
else
|
||||
if (allocated(level%sm)) level%sm2 => level%sm
|
||||
end if
|
||||
|
||||
return
|
||||
end subroutine restore_smoothers
|
||||
|
||||
#else
|
||||
|
||||
subroutine save_smoothers(level,save1, save2,info)
|
||||
type(amg_z_onelev_type), intent(inout) :: level
|
||||
class(amg_z_base_smoother_type), allocatable , intent(inout) :: save1, save2
|
||||
@@ -565,5 +630,5 @@ contains
|
||||
|
||||
return
|
||||
end subroutine restore_smoothers
|
||||
|
||||
#endif
|
||||
end subroutine amg_z_hierarchy_bld
|
||||
@@ -186,8 +186,8 @@ subroutine amg_z_smoothers_bld(a,desc_a,prec,info,amold,vmold,imold)
|
||||
& ' but it has been changed to distributed.'
|
||||
end if
|
||||
|
||||
case(psb_ilu_n_, psb_ilu_t_,psb_milu_n_)
|
||||
if (prec%precv(iszv)%sm%sv%get_id() /= psb_ilu_n_) then
|
||||
case(amg_ilu_n_, amg_ilu_t_,amg_milu_n_)
|
||||
if (prec%precv(iszv)%sm%sv%get_id() /= amg_ilu_n_) then
|
||||
write(psb_err_unit,*) &
|
||||
& 'AMG4PSBLAS: Warning: original coarse solver was requested as ',&
|
||||
& amg_fact_names(coarse_solve_id)
|
||||
|
||||
@@ -84,6 +84,7 @@ subroutine amg_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
use amg_z_diag_solver
|
||||
use amg_z_l1_diag_solver
|
||||
use amg_z_ilu_solver
|
||||
use amg_z_jac_solver
|
||||
use amg_z_id_solver
|
||||
use amg_z_gs_solver
|
||||
use amg_z_ainv_solver
|
||||
@@ -199,6 +200,15 @@ subroutine amg_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
end if
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
|
||||
case('COARSE_INVFILL')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
& ': Error: Inconsistent specification of WHAT vs. ILEV'
|
||||
info = -2
|
||||
return
|
||||
end if
|
||||
call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
|
||||
|
||||
case('BJAC_ITRACE')
|
||||
if (ilev_ /= nlev_) then
|
||||
write(psb_err_unit,*) name,&
|
||||
@@ -248,6 +258,11 @@ subroutine amg_zcprecseti(p,what,val,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('COARSE_INVFILL')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('INV_FILLIN',val,info,pos=pos)
|
||||
end if
|
||||
|
||||
case('BJAC_ITRACE')
|
||||
if (nlev_ > 1) then
|
||||
call p%precv(nlev_)%set('SMOOTHER_ITRACE',val,info,pos=pos)
|
||||
@@ -314,6 +329,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
use amg_z_diag_solver
|
||||
use amg_z_l1_diag_solver
|
||||
use amg_z_ilu_solver
|
||||
use amg_z_jac_solver
|
||||
use amg_z_id_solver
|
||||
use amg_z_gs_solver
|
||||
use amg_z_ainv_solver
|
||||
@@ -483,7 +499,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -499,7 +515,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -522,7 +538,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -530,21 +546,21 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#endif
|
||||
case('ILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('MILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
@@ -559,7 +575,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -589,7 +605,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -627,7 +643,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -737,7 +753,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -752,7 +768,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#elif defined(HAVE_MUMPS_)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_mumps_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
#endif
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
@@ -775,7 +791,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -783,21 +799,21 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
#endif
|
||||
case('ILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('ILUT')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_t_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_t_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_repl_mat_,info,pos=pos)
|
||||
case('MILU')
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_milu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_milu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_repl_mat_)
|
||||
@@ -812,7 +828,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -842,7 +858,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
@@ -880,7 +896,7 @@ subroutine amg_zcprecsetc(p,what,string,info,ilev,ilmax,pos,idx)
|
||||
call p%precv(nlev_)%set('COARSE_MAT',amg_distr_mat_,info,pos=pos)
|
||||
#else
|
||||
call p%precv(nlev_)%set('SMOOTHER_TYPE',amg_bjac_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',psb_ilu_n_,info,pos=pos)
|
||||
call p%precv(nlev_)%set('SUB_SOLVE',amg_ilu_n_,info,pos=pos)
|
||||
if (hier_asb) &
|
||||
& call amg_warn_coarse_mat(p%precv(nlev_)%parms%get_coarse_mat(),&
|
||||
& amg_distr_mat_)
|
||||
|
||||
@@ -170,7 +170,7 @@ subroutine amg_zfile_prec_descr(prec,info,iout,root, verbosity,prefix)
|
||||
call prec%precv(1)%sm%descr(info,iout=iout_,prefix=prefix)
|
||||
nswps = prec%precv(1)%parms%sweeps_pre
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Number of sweeps : ',nswps
|
||||
write(iout_,*) trim(prefix_), ' Number of sweeps/degree : ',nswps
|
||||
write(iout_,*) trim(prefix_)
|
||||
|
||||
else if (nlev > 1) then
|
||||
|
||||
@@ -0,0 +1,152 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (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: amg_dfile_prec_memory_use.f90
|
||||
!
|
||||
!
|
||||
! Subroutine: amg_file_prec_memory_use
|
||||
! Version: complex
|
||||
!
|
||||
! This routine prints a memory_useiption of the preconditioner to the standard
|
||||
! output or to a file. It must be called after the preconditioner has been
|
||||
! built by amg_precbld.
|
||||
!
|
||||
! Arguments:
|
||||
! p - type(amg_Tprec_type), input.
|
||||
! The preconditioner data structure to be printed out.
|
||||
! info - integer, output.
|
||||
! error code.
|
||||
! iout - integer, input, optional.
|
||||
! The id of the file where the preconditioner description
|
||||
! will be printed. If iout is not present, then the standard
|
||||
! output is condidered.
|
||||
! root - integer, input, optional.
|
||||
! The id of the process printing the message; -1 acts as a wildcard.
|
||||
! Default is psb_root_
|
||||
!
|
||||
!
|
||||
!
|
||||
! verbosity:
|
||||
! <0: suppress all messages
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_zfile_prec_memory_use(prec,info,iout,root, verbosity,prefix,global)
|
||||
use psb_base_mod
|
||||
use amg_z_prec_mod, amg_protect_name => amg_zfile_prec_memory_use
|
||||
use amg_z_inner_mod
|
||||
use amg_z_gs_solver
|
||||
|
||||
implicit none
|
||||
! Arguments
|
||||
class(amg_zprec_type), intent(in) :: prec
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
integer(psb_ipk_), intent(in), optional :: root
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
integer(psb_ipk_) :: ilev, nlev, ilmin, nswps
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: me, np
|
||||
logical :: is_symgs
|
||||
character(len=20), parameter :: name='amg_file_prec_memory_use'
|
||||
integer(psb_ipk_) :: iout_, root_, verbosity_
|
||||
logical :: global_
|
||||
character(1024) :: prefix_
|
||||
|
||||
info = psb_success_
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
if (iout_ < 0) iout_ = psb_out_unit
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
|
||||
ctxt = prec%ctxt
|
||||
call psb_info(ctxt,me,np)
|
||||
prefix_ = ""
|
||||
if (verbosity_ == 0) then
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
end if
|
||||
else if (verbosity_ > 0) then
|
||||
if (present(prefix)) then
|
||||
write(prefix_,'(a,a,i5,a)') prefix,' from process ',me,': '
|
||||
else
|
||||
write(prefix_,'(a,i5,a)') 'Process ',me,': '
|
||||
end if
|
||||
|
||||
end if
|
||||
|
||||
if (present(root)) then
|
||||
root_ = root
|
||||
else
|
||||
root_ = psb_root_
|
||||
end if
|
||||
if (root_ == -1) root_ = me
|
||||
|
||||
if (allocated(prec%precv)) then
|
||||
if (verbosity_ >=0) then
|
||||
if (me == root_) then
|
||||
write(iout_,*)
|
||||
write(iout_,'(a,1x,a)') trim(prefix_),'Preconditioner memory usage'
|
||||
end if
|
||||
nlev = size(prec%precv)
|
||||
do ilev=1,nlev
|
||||
call prec%precv(ilev)%memory_use(ilev,nlev,ilmin,info, &
|
||||
& iout=iout_,verbosity=verbosity_,prefix=trim(prefix_),global=global)
|
||||
end do
|
||||
|
||||
else
|
||||
write(iout_,*) trim(name), &
|
||||
& ': Error: no base preconditioner available, something is wrong!'
|
||||
info = -2
|
||||
return
|
||||
endif
|
||||
end if
|
||||
9998 continue
|
||||
end subroutine amg_zfile_prec_memory_use
|
||||
@@ -98,6 +98,7 @@ subroutine amg_zprecinit(ctxt,prec,ptype,info)
|
||||
use amg_z_diag_solver
|
||||
use amg_z_ilu_solver
|
||||
use amg_z_gs_solver
|
||||
|
||||
#if defined(HAVE_UMF_)
|
||||
use amg_z_umf_solver
|
||||
#endif
|
||||
@@ -155,7 +156,6 @@ subroutine amg_zprecinit(ctxt,prec,ptype,info)
|
||||
if (info /= psb_success_) return
|
||||
allocate(amg_z_diag_solver_type :: prec%precv(ilev_)%sm%sv, stat=info)
|
||||
call prec%precv(ilev_)%default()
|
||||
|
||||
case ('L1-DIAG','L1-JACOBI','L1_DIAG','L1_JACOBI')
|
||||
nlev_ = 1
|
||||
ilev_ = 1
|
||||
|
||||
@@ -15,6 +15,7 @@ amg_c_base_onelev_csetc.o \
|
||||
amg_c_base_onelev_cseti.o \
|
||||
amg_c_base_onelev_csetr.o \
|
||||
amg_c_base_onelev_descr.o \
|
||||
amg_c_base_onelev_memory_use.o \
|
||||
amg_c_base_onelev_dump.o \
|
||||
amg_c_base_onelev_free.o \
|
||||
amg_c_base_onelev_free_smoothers.o \
|
||||
@@ -31,6 +32,7 @@ amg_d_base_onelev_csetc.o \
|
||||
amg_d_base_onelev_cseti.o \
|
||||
amg_d_base_onelev_csetr.o \
|
||||
amg_d_base_onelev_descr.o \
|
||||
amg_d_base_onelev_memory_use.o \
|
||||
amg_d_base_onelev_dump.o \
|
||||
amg_d_base_onelev_free.o \
|
||||
amg_d_base_onelev_free_smoothers.o \
|
||||
@@ -47,6 +49,7 @@ amg_s_base_onelev_csetc.o \
|
||||
amg_s_base_onelev_cseti.o \
|
||||
amg_s_base_onelev_csetr.o \
|
||||
amg_s_base_onelev_descr.o \
|
||||
amg_s_base_onelev_memory_use.o \
|
||||
amg_s_base_onelev_dump.o \
|
||||
amg_s_base_onelev_free.o \
|
||||
amg_s_base_onelev_free_smoothers.o \
|
||||
@@ -63,6 +66,7 @@ amg_z_base_onelev_csetc.o \
|
||||
amg_z_base_onelev_cseti.o \
|
||||
amg_z_base_onelev_csetr.o \
|
||||
amg_z_base_onelev_descr.o \
|
||||
amg_z_base_onelev_memory_use.o \
|
||||
amg_z_base_onelev_dump.o \
|
||||
amg_z_base_onelev_free.o \
|
||||
amg_z_base_onelev_free_smoothers.o \
|
||||
|
||||
@@ -46,6 +46,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
use amg_c_as_smoother
|
||||
use amg_c_diag_solver
|
||||
use amg_c_l1_diag_solver
|
||||
use amg_c_jac_solver
|
||||
use amg_c_ilu_solver
|
||||
use amg_c_id_solver
|
||||
use amg_c_gs_solver
|
||||
@@ -78,6 +79,8 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
type(amg_c_as_smoother_type) :: amg_c_as_smoother_mold
|
||||
type(amg_c_diag_solver_type) :: amg_c_diag_solver_mold
|
||||
type(amg_c_l1_diag_solver_type) :: amg_c_l1_diag_solver_mold
|
||||
type(amg_c_jac_solver_type) :: amg_c_jac_solver_mold
|
||||
type(amg_c_l1_jac_solver_type) :: amg_c_l1_jac_solver_mold
|
||||
type(amg_c_ilu_solver_type) :: amg_c_ilu_solver_mold
|
||||
type(amg_c_id_solver_type) :: amg_c_id_solver_mold
|
||||
type(amg_c_gs_solver_type) :: amg_c_gs_solver_mold
|
||||
@@ -185,10 +188,10 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('NONE','NOPREC','FACT_NONE')
|
||||
call lv%set(amg_c_id_solver_mold,info,pos=pos)
|
||||
|
||||
case ('DIAG')
|
||||
case ('DIAG','JACOBI')
|
||||
call lv%set(amg_c_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-DIAG')
|
||||
case ('L1-DIAG','L1-JACOBI')
|
||||
call lv%set(amg_c_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case ('GS','FGS','FWGS')
|
||||
@@ -243,7 +246,7 @@ subroutine amg_c_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case('DEC')
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_c_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_c_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
|
||||
@@ -164,7 +164,7 @@ subroutine amg_c_base_onelev_cseti(lv,what,val,info,pos,idx)
|
||||
case (amg_bwgs_)
|
||||
call lv%set(amg_c_bwgs_solver_mold,info,pos=pos)
|
||||
|
||||
case (psb_ilu_n_,psb_milu_n_,psb_ilu_t_)
|
||||
case (amg_ilu_n_,amg_milu_n_,amg_ilu_t_)
|
||||
call lv%set(amg_c_ilu_solver_mold,info,pos=pos)
|
||||
if (info == 0) then
|
||||
if ((ipos_==amg_smooth_pre_) .or.(ipos_==amg_smooth_both_)) then
|
||||
|
||||
@@ -109,6 +109,8 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
type(psb_cspmat_type) :: ac, op_restr, op_prol
|
||||
integer(psb_ipk_) :: nzl, inl
|
||||
integer(psb_ipk_) :: debug_level, debug_unit
|
||||
integer(psb_ipk_), save :: idx_matbld=-1, idx_matasb=-1, idx_mapbld=-1
|
||||
logical, parameter :: do_timings=.false.
|
||||
|
||||
name='amg_c_onelev_mat_asb'
|
||||
call psb_erractionsave(err_act)
|
||||
@@ -120,6 +122,12 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
info = psb_success_
|
||||
ctxt = desc_a%get_context()
|
||||
call psb_info(ctxt,me,np)
|
||||
if ((do_timings).and.(idx_matbld==-1)) &
|
||||
& idx_matbld = psb_get_timer_idx("LEV_MASB: mat_bld")
|
||||
if ((do_timings).and.(idx_matasb==-1)) &
|
||||
& idx_matasb = psb_get_timer_idx("LEV_MASB: mat_asb")
|
||||
if ((do_timings).and.(idx_mapbld==-1)) &
|
||||
& idx_mapbld = psb_get_timer_idx("LEV_MASB: map_bld")
|
||||
|
||||
call amg_check_def(lv%parms%aggr_prol,'Smoother',&
|
||||
& amg_smooth_prol_,is_legal_ml_aggr_prol)
|
||||
@@ -139,9 +147,10 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
! the mapping defined by amg_aggrmap_bld and applying the aggregation
|
||||
! algorithm specified by lv%iprcparm(amg_aggr_prol_)
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matbld)
|
||||
call lv%aggr%mat_bld(lv%parms,a,desc_a,ilaggr,nlaggr,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,t_prol,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_matbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='amg_aggrmat_asb')
|
||||
goto 9999
|
||||
@@ -151,14 +160,17 @@ subroutine amg_c_base_onelev_mat_asb(lv,a,desc_a,ilaggr,nlaggr,t_prol,info)
|
||||
! Now build its descriptor and convert global indices for
|
||||
! ac, op_restr and op_prol
|
||||
!
|
||||
if (do_timings) call psb_tic(idx_matasb)
|
||||
if (info == psb_success_) &
|
||||
& call lv%aggr%mat_asb(lv%parms,a,desc_a,&
|
||||
& lv%ac,lv%desc_ac,op_prol,op_restr,info)
|
||||
|
||||
if (do_timings) call psb_toc(idx_matasb)
|
||||
if (do_timings) call psb_tic(idx_mapbld)
|
||||
if (info == psb_success_) call lv%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
|
||||
|
||||
if (info == psb_success_) call lv%aggr%bld_map(desc_a, lv%desc_ac,&
|
||||
& ilaggr,nlaggr,op_restr,op_prol,lv%linmap,info)
|
||||
if (do_timings) call psb_toc(idx_mapbld)
|
||||
if(info /= psb_success_) then
|
||||
call psb_errpush(psb_err_from_subroutine_,name,a_err='mat_asb/map_bld')
|
||||
goto 9999
|
||||
|
||||
@@ -0,0 +1,150 @@
|
||||
!
|
||||
!
|
||||
! AMG4PSBLAS version 1.0
|
||||
! Algebraic Multigrid Package
|
||||
! based on PSBLAS (Parallel Sparse BLAS version 3.7)
|
||||
!
|
||||
! (C) Copyright 2021
|
||||
!
|
||||
! Salvatore Filippone
|
||||
! Pasqua D'Ambra
|
||||
! Fabio Durastante
|
||||
!
|
||||
! Redistribution and use in source and binary forms, with or without
|
||||
! modification, are permitted provided that the following conditions
|
||||
! are met:
|
||||
! 1. Redistributions of source code must retain the above copyright
|
||||
! notice, this list of conditions and the following disclaimer.
|
||||
! 2. Redistributions in binary form must reproduce the above copyright
|
||||
! notice, this list of conditions, and the following disclaimer in the
|
||||
! documentation and/or other materials provided with the distribution.
|
||||
! 3. The name of the AMG4PSBLAS group or the names of its contributors may
|
||||
! not be used to endorse or promote products derived from this
|
||||
! software without specific written permission.
|
||||
!
|
||||
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
|
||||
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
|
||||
! PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AMG4PSBLAS GROUP OR ITS CONTRIBUTORS
|
||||
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
! POSSIBILITY OF SUCH DAMAGE.
|
||||
!
|
||||
!
|
||||
!
|
||||
!
|
||||
! verbosity:
|
||||
! <0: suppress all messages
|
||||
! 0: normal
|
||||
! >1: increased details
|
||||
!
|
||||
subroutine amg_c_base_onelev_memory_use(lv,il,nl,ilmin,info,iout,verbosity,prefix,global)
|
||||
|
||||
use psb_base_mod
|
||||
use amg_c_onelev_mod, amg_protect_name => amg_c_base_onelev_memory_use
|
||||
Implicit None
|
||||
! Arguments
|
||||
class(amg_c_onelev_type), intent(in) :: lv
|
||||
integer(psb_ipk_), intent(in) :: il,nl,ilmin
|
||||
integer(psb_ipk_), intent(out) :: info
|
||||
integer(psb_ipk_), intent(in), optional :: iout
|
||||
character(len=*), intent(in), optional :: prefix
|
||||
integer(psb_ipk_), intent(in), optional :: verbosity
|
||||
logical, intent(in), optional :: global
|
||||
|
||||
|
||||
! Local variables
|
||||
type(psb_ctxt_type) :: ctxt
|
||||
integer(psb_ipk_) :: err_act ,me, np
|
||||
character(len=20), parameter :: name='amg_c_base_onelev_memory_use'
|
||||
integer(psb_ipk_) :: iout_, verbosity_
|
||||
logical :: coarse, global_
|
||||
character(1024) :: prefix_
|
||||
integer(psb_epk_), allocatable :: sz(:)
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
ctxt = lv%base_desc%get_ctxt()
|
||||
call psb_info(ctxt,me,np)
|
||||
|
||||
coarse = (il==nl)
|
||||
|
||||
if (present(iout)) then
|
||||
iout_ = iout
|
||||
else
|
||||
iout_ = psb_out_unit
|
||||
end if
|
||||
|
||||
if (present(verbosity)) then
|
||||
verbosity_ = verbosity
|
||||
else
|
||||
verbosity_ = 0
|
||||
end if
|
||||
if (verbosity_ < 0) goto 9998
|
||||
if (present(global)) then
|
||||
global_ = global
|
||||
else
|
||||
global_ = .true.
|
||||
end if
|
||||
|
||||
if (present(prefix)) then
|
||||
prefix_ = prefix
|
||||
else
|
||||
prefix_ = ""
|
||||
end if
|
||||
|
||||
if ((me == 0).or.(verbosity_>0)) write(iout_,*) trim(prefix_)
|
||||
|
||||
if (global_) then
|
||||
allocate(sz(6))
|
||||
sz(:) = 0
|
||||
sz(1) = lv%base_a%sizeof()
|
||||
sz(2) = lv%base_desc%sizeof()
|
||||
if (il >1) sz(3) = lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) sz(4) = lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) sz(5) = lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) sz(6) = lv%wrk%sizeof()
|
||||
call psb_sum(ctxt,sz)
|
||||
if (me == 0) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', sz(1)
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', sz(2)
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', sz(3)
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', sz(4)
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', sz(5)
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', sz(6)
|
||||
end if
|
||||
|
||||
else
|
||||
if ((me == 0).or.(verbosity_>0)) then
|
||||
if (coarse) then
|
||||
write(iout_,*) trim(prefix_), ' Level ',il,' (coarse)'
|
||||
else
|
||||
write(iout_,*) trim(prefix_), ' Level ',il
|
||||
end if
|
||||
write(iout_,*) trim(prefix_), ' Matrix:', lv%base_a%sizeof()
|
||||
write(iout_,*) trim(prefix_), ' Descriptor:', lv%base_desc%sizeof()
|
||||
if (il >1) write(iout_,*) trim(prefix_), ' Linear map:', lv%linmap%sizeof()
|
||||
if (allocated(lv%sm)) write(iout_,*) trim(prefix_), ' Smoother:', lv%sm%sizeof()
|
||||
if (allocated(lv%sm2a)) write(iout_,*) trim(prefix_), ' Smoother 2:', lv%sm2a%sizeof()
|
||||
if (allocated(lv%wrk)) write(iout_,*) trim(prefix_), ' Workspace:', lv%wrk%sizeof()
|
||||
end if
|
||||
endif
|
||||
|
||||
9998 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
return
|
||||
|
||||
end subroutine amg_c_base_onelev_memory_use
|
||||
@@ -43,10 +43,12 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
use amg_d_dec_aggregator_mod
|
||||
use amg_d_symdec_aggregator_mod
|
||||
use amg_d_parmatch_aggregator_mod
|
||||
use amg_d_poly_smoother
|
||||
use amg_d_jac_smoother
|
||||
use amg_d_as_smoother
|
||||
use amg_d_diag_solver
|
||||
use amg_d_l1_diag_solver
|
||||
use amg_d_jac_solver
|
||||
use amg_d_ilu_solver
|
||||
use amg_d_id_solver
|
||||
use amg_d_gs_solver
|
||||
@@ -85,6 +87,8 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
type(amg_d_as_smoother_type) :: amg_d_as_smoother_mold
|
||||
type(amg_d_diag_solver_type) :: amg_d_diag_solver_mold
|
||||
type(amg_d_l1_diag_solver_type) :: amg_d_l1_diag_solver_mold
|
||||
type(amg_d_jac_solver_type) :: amg_d_jac_solver_mold
|
||||
type(amg_d_l1_jac_solver_type) :: amg_d_l1_jac_solver_mold
|
||||
type(amg_d_ilu_solver_type) :: amg_d_ilu_solver_mold
|
||||
type(amg_d_id_solver_type) :: amg_d_id_solver_mold
|
||||
type(amg_d_gs_solver_type) :: amg_d_gs_solver_mold
|
||||
@@ -92,6 +96,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
type(amg_d_ainv_solver_type) :: amg_d_ainv_solver_mold
|
||||
type(amg_d_invk_solver_type) :: amg_d_invk_solver_mold
|
||||
type(amg_d_invt_solver_type) :: amg_d_invt_solver_mold
|
||||
type(amg_d_poly_smoother_type) :: amg_d_poly_smoother_mold
|
||||
#if defined(HAVE_UMF_)
|
||||
type(amg_d_umf_solver_type) :: amg_d_umf_solver_mold
|
||||
#endif
|
||||
@@ -153,6 +158,9 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
call lv%set(amg_d_as_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_ilu_solver_mold,info,pos=pos)
|
||||
|
||||
case ('POLY')
|
||||
call lv%set(amg_d_poly_smoother_mold,info,pos=pos)
|
||||
if (info == 0) call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
|
||||
case ('GS','FWGS')
|
||||
call lv%set(amg_d_jac_smoother_mold,info,pos='pre')
|
||||
if (info == 0) call lv%set(amg_d_gs_solver_mold,info,pos='pre')
|
||||
@@ -198,10 +206,10 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
case ('NONE','NOPREC','FACT_NONE')
|
||||
call lv%set(amg_d_id_solver_mold,info,pos=pos)
|
||||
|
||||
case ('DIAG')
|
||||
case ('DIAG','JACOBI')
|
||||
call lv%set(amg_d_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case ('L1-DIAG')
|
||||
case ('L1-DIAG','L1-JACOBI')
|
||||
call lv%set(amg_d_l1_diag_solver_mold,info,pos=pos)
|
||||
|
||||
case ('GS','FGS','FWGS')
|
||||
@@ -264,7 +272,7 @@ subroutine amg_d_base_onelev_csetc(lv,what,val,info,pos,idx)
|
||||
end if
|
||||
|
||||
select case(val)
|
||||
case('DEC')
|
||||
case('DEC','DECOUPLED')
|
||||
allocate(amg_d_dec_aggregator_type :: lv%aggr, stat=info)
|
||||
case('SYMDEC')
|
||||
allocate(amg_d_symdec_aggregator_type :: lv%aggr, stat=info)
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user