40 integer(kind=kint) :: totalmpc, mpc_method, solver_type
42 totalmpc = hecmesh%mpc%n_mpc
45 if (totalmpc == 0)
then
51 call hecmw_mpc_scale(hecmesh)
54 if (mpc_method < 1 .or. 3 < mpc_method)
then
56 if (solver_type > 1)
then
64 if (mpc_method == 2)
then
65 write(*,*)
'WARNING: MPCMETHOD=2 (MPCCG) is deprecated; may not work correctly'
70 select case (mpc_method)
79 call hecmw_mpc_mesh_copy(hecmesh, hecmeshmpc)
96 integer(kind=kint) :: totalmpc, mpc_method
98 totalmpc = hecmesh%mpc%n_mpc
101 if (totalmpc == 0)
then
106 call hecmw_mpc_scale(hecmesh)
115 hecmatmpc%N = hecmat%N
116 hecmatmpc%NP = hecmat%NP
117 hecmatmpc%NDOF = hecmat%NDOF
118 allocate(hecmatmpc%B(
size(hecmat%B)))
119 allocate(hecmatmpc%X(
size(hecmat%X)))
133 integer(kind=kint) :: totalmpc, mpc_method
135 totalmpc = hecmesh%mpc%n_mpc
138 if (totalmpc == 0)
then
146 select case (mpc_method)
154 call hecmw_mpc_mesh_free(hecmeshmpc)
155 deallocate(hecmeshmpc)
158 deallocate(hecmatmpc)
174 integer(kind=kint) :: totalmpc, mpc_method
176 totalmpc = hecmesh%mpc%n_mpc
179 if (totalmpc == 0)
then
186 select case (mpc_method)
193 deallocate(hecmatmpc)
210 integer(kind=kint) :: totalmpc, mpc_method
212 totalmpc = hecmesh%mpc%n_mpc
215 if (totalmpc == 0)
return
219 select case (mpc_method)
243 real(kind=
kreal),
allocatable :: btmp(:)
244 real(kind=
kreal) :: time_dumm
245 integer(kind=kint) :: totalmpc, mpc_method, i
247 totalmpc = hecmesh%mpc%n_mpc
250 if (totalmpc == 0)
return
254 select case (mpc_method)
258 allocate(btmp(hecmat%NP*hecmat%NDOF))
259 do i = 1, hecmat%NP*hecmat%NDOF
260 btmp(i) = hecmat%B(i)
262 call hecmw_trans_b(hecmesh, hecmat, btmp, hecmatmpc%B, time_dumm)
265 call hecmw_trans_b(hecmesh, hecmat, hecmat%B, hecmatmpc%B, time_dumm)
266 hecmatmpc%Iarray=hecmat%Iarray
267 hecmatmpc%Rarray=hecmat%Rarray
282 real(kind=
kreal) :: time_dumm
283 integer(kind=kint) :: totalmpc, mpc_method, i
285 totalmpc = hecmesh%mpc%n_mpc
288 if (totalmpc == 0)
return
292 select case (mpc_method)
296 call hecmw_tback_x(hecmesh, hecmat%NDOF, hecmat%X, time_dumm)
298 do i = 1,
size(hecmat%X)
299 hecmat%X(i) = hecmatmpc%X(i)
301 call hecmw_tback_x(hecmesh, hecmat%NDOF, hecmat%X, time_dumm)
302 hecmat%Iarray=hecmatmpc%Iarray
303 hecmat%Rarray=hecmatmpc%Rarray
316 real(kind=
kreal),
intent(inout) :: mass(:)
318 real(kind=
kreal),
allocatable :: mtmp(:)
319 real(kind=
kreal) :: time_dumm
320 integer(kind=kint) :: totalmpc, mpc_method, i
322 totalmpc = hecmesh%mpc%n_mpc
325 if (totalmpc == 0)
return
329 select case (mpc_method)
333 allocate(mtmp(hecmat%NP*hecmat%NDOF))
335 call hecmw_ttvec(hecmesh, hecmat%NDOF, mass, mtmp, time_dumm)
336 do i = 1, hecmat%NP*hecmat%NDOF
353 integer(kind=kint),
intent(in) :: neig
354 real(kind=
kreal),
intent(inout) :: eigvec(:,:)
356 real(kind=
kreal) :: time_dumm
357 integer(kind=kint) :: totalmpc, mpc_method, i
359 totalmpc = hecmesh%mpc%n_mpc
362 if (totalmpc == 0)
return
366 select case (mpc_method)
371 call hecmw_tback_x(hecmesh, hecmat%NDOF, eigvec(:,i), time_dumm)
386 integer(kind=kint),
intent(out) :: mark(:)
388 integer(kind=kint) :: ndof, i, j, k, kk
392 outer:
do i = 1, hecmesh%mpc%n_mpc
393 do j = hecmesh%mpc%mpc_index(i-1)+1, hecmesh%mpc%mpc_index(i)
394 if (hecmesh%mpc%mpc_dof(j) > ndof) cycle outer
396 k = hecmesh%mpc%mpc_index(i-1)+1
397 kk = ndof * (hecmesh%mpc%mpc_item(k) - 1) + hecmesh%mpc%mpc_dof(k)
407 subroutine hecmw_mpc_scale(hecMESH)
410 integer(kind=kint) :: i, j, k
411 real(kind=
kreal) :: wval
415 do i = 1, hecmesh%mpc%n_mpc
416 k = hecmesh%mpc%mpc_index(i-1)+1
417 wval = 1.d0 / hecmesh%mpc%mpc_val(k)
418 hecmesh%mpc%mpc_val(k) = 1.d0
419 do j = hecmesh%mpc%mpc_index(i-1)+2, hecmesh%mpc%mpc_index(i)
420 hecmesh%mpc%mpc_val(j) = hecmesh%mpc%mpc_val(j) * wval
422 hecmesh%mpc%mpc_const(i) = hecmesh%mpc%mpc_const(i) * wval
427 end subroutine hecmw_mpc_scale
435 subroutine hecmw_trans_b(hecMESH, hecMAT, B, BT, COMMtime)
439 real(kind=
kreal),
intent(in) :: b(:)
440 real(kind=
kreal),
intent(out),
target :: bt(:)
441 real(kind=
kreal),
intent(inout) :: commtime
443 real(kind=
kreal),
allocatable :: w(:)
444 real(kind=
kreal),
pointer :: xg(:)
445 integer(kind=kint) :: ndof, i, j, k, kk, flg_bak
449 allocate(w(hecmesh%n_node * ndof))
457 do i = 1, hecmat%N * ndof
464 outer:
do i = 1, hecmesh%mpc%n_mpc
465 do j = hecmesh%mpc%mpc_index(i-1)+1, hecmesh%mpc%mpc_index(i)
466 if (hecmesh%mpc%mpc_dof(j) > ndof) cycle outer
468 k = hecmesh%mpc%mpc_index(i-1) + 1
469 kk = ndof * (hecmesh%mpc%mpc_item(k) - 1) + hecmesh%mpc%mpc_dof(k)
470 xg(kk) = hecmesh%mpc%mpc_const(i)
485 end subroutine hecmw_trans_b
493 subroutine hecmw_tback_x(hecMESH, ndof, X, COMMtime)
496 integer(kind=kint),
intent(in) :: ndof
497 real(kind=
kreal),
intent(inout) :: x(:)
498 real(kind=
kreal),
intent(inout) :: commtime
500 real(kind=
kreal),
allocatable :: w(:)
501 integer(kind=kint) :: i, j, k, kk
503 allocate(w(hecmesh%n_node * ndof))
506 call hecmw_tvec(hecmesh, ndof, x, w, commtime)
511 do i= 1, hecmesh%nn_internal * ndof
517 outer:
do i = 1, hecmesh%mpc%n_mpc
518 do j = hecmesh%mpc%mpc_index(i-1)+1, hecmesh%mpc%mpc_index(i)
519 if (hecmesh%mpc%mpc_dof(j) > ndof) cycle outer
521 k = hecmesh%mpc%mpc_index(i-1) + 1
522 kk = ndof * (hecmesh%mpc%mpc_item(k) - 1) + hecmesh%mpc%mpc_dof(k)
523 x(kk) = x(kk) + hecmesh%mpc%mpc_const(i)
532 else if (ndof == 2)
then
537 end subroutine hecmw_tback_x
539 subroutine hecmw_mpc_mesh_copy(src, dst)
544 dst%MPI_COMM = src%MPI_COMM
545 dst%PETOT = src%PETOT
546 dst%PEsmpTOT = src%PEsmpTOT
547 dst%my_rank = src%my_rank
548 dst%n_subdomain = src%n_subdomain
549 dst%n_node = src%n_node
550 dst%nn_internal = src%nn_internal
551 dst%n_elem = src%n_elem
552 dst%ne_internal = src%ne_internal
553 dst%n_elem_type = src%n_elem_type
554 dst%n_dof = src%n_dof
555 dst%n_neighbor_pe = src%n_neighbor_pe
556 if (src%n_neighbor_pe > 0)
then
557 allocate(dst%neighbor_pe(dst%n_neighbor_pe))
558 dst%neighbor_pe(:) = src%neighbor_pe(:)
559 allocate(dst%import_index(0:dst%n_neighbor_pe))
560 dst%import_index(:)= src%import_index(:)
561 allocate(dst%export_index(0:dst%n_neighbor_pe))
562 dst%export_index(:)= src%export_index(:)
563 allocate(dst%import_item(dst%import_index(dst%n_neighbor_pe)))
564 dst%import_item(:) = src%import_item(:)
565 allocate(dst%export_item(dst%export_index(dst%n_neighbor_pe)))
566 dst%export_item(:) = src%export_item(:)
568 allocate(dst%global_node_ID(dst%n_node))
569 dst%global_node_ID(1:dst%n_node) = src%global_node_ID(1:dst%n_node)
570 allocate(dst%node_ID(2*dst%n_node))
571 dst%node_ID(1:2*dst%n_node) = src%node_ID(1:2*dst%n_node)
572 allocate(dst%elem_type_item(dst%n_elem_type))
573 dst%elem_type_item(:) = src%elem_type_item(:)
575 dst%mpc%n_mpc = src%mpc%n_mpc
576 dst%mpc%mpc_index => src%mpc%mpc_index
577 dst%mpc%mpc_item => src%mpc%mpc_item
578 dst%mpc%mpc_dof => src%mpc%mpc_dof
579 dst%mpc%mpc_val => src%mpc%mpc_val
580 dst%mpc%mpc_const => src%mpc%mpc_const
582 dst%node_group%n_grp = src%node_group%n_grp
583 dst%node_group%n_bc = src%node_group%n_bc
584 dst%node_group%grp_name => src%node_group%grp_name
585 dst%node_group%grp_index => src%node_group%grp_index
586 dst%node_group%grp_item => src%node_group%grp_item
587 dst%node_group%bc_grp_ID => src%node_group%bc_grp_ID
588 dst%node_group%bc_grp_type => src%node_group%bc_grp_type
589 dst%node_group%bc_grp_index => src%node_group%bc_grp_index
590 dst%node_group%bc_grp_dof => src%node_group%bc_grp_dof
591 dst%node_group%bc_grp_val => src%node_group%bc_grp_val
594 end subroutine hecmw_mpc_mesh_copy
596 subroutine hecmw_mpc_mesh_free(hecMESH)
599 if (hecmesh%n_neighbor_pe > 1)
then
600 deallocate(hecmesh%neighbor_pe)
601 deallocate(hecmesh%import_index)
602 deallocate(hecmesh%export_index)
603 deallocate(hecmesh%import_item)
604 deallocate(hecmesh%export_item)
606 deallocate(hecmesh%global_node_ID)
607 deallocate(hecmesh%node_ID)
608 deallocate(hecmesh%elem_type_item)
609 end subroutine hecmw_mpc_mesh_free
subroutine, public hecmw_trimatmul_ttkt_mpc(hecMESH, hecMAT, hecTKT)
subroutine, public hecmw_mat_ass_equation_rhs(hecMESH, hecMAT)
subroutine, public hecmw_mat_ass_equation(hecMESH, hecMAT)
integer(kind=kint) function, public hecmw_mat_get_solver_type(hecMAT)
integer(kind=kint) function, public hecmw_mat_get_flag_mpcmatvec(hecMAT)
subroutine, public hecmw_mat_init(hecMAT)
subroutine, public hecmw_mat_finalize(hecMAT)
subroutine, public hecmw_mat_set_flag_mpcmatvec(hecMAT, flag_mpcmatvec)
integer(kind=kint) function, public hecmw_mat_get_mpc_method(hecMAT)
subroutine, public hecmw_mat_set_mpc_method(hecMAT, mpc_method)
subroutine, public hecmw_mpc_tback_sol(hecMESH, hecMAT, hecMATmpc)
subroutine, public hecmw_mpc_mat_ass(hecMESH, hecMAT, hecMESHmpc, hecMATmpc)
subroutine, public hecmw_mpc_mat_init(hecMESH, hecMAT, hecMESHmpc, hecMATmpc)
subroutine, public hecmw_mpc_mat_init_explicit(hecMESH, hecMAT, hecMATmpc)
subroutine, public hecmw_mpc_trans_mass(hecMESH, hecMAT, mass)
subroutine, public hecmw_mpc_mat_finalize(hecMESH, hecMAT, hecMESHmpc, hecMATmpc)
subroutine, public hecmw_mpc_mat_finalize_explicit(hecMESH, hecMAT, hecMATmpc)
subroutine, public hecmw_mpc_tback_eigvec(hecMESH, hecMAT, neig, eigvec)
subroutine, public hecmw_mpc_trans_rhs(hecMESH, hecMAT, hecMATmpc)
subroutine, public hecmw_mpc_mark_slave(hecMESH, hecMAT, mark)
subroutine, public hecmw_ttvec(hecMESH, ndof, X, Y, COMMtime)
subroutine, public hecmw_tvec(hecMESH, ndof, X, Y, COMMtime)
subroutine, public hecmw_matresid(hecMESH, hecMAT, X, B, R, COMMtime)
integer(kind=kint), parameter hecmw_sum
integer(kind=4), parameter kreal
subroutine hecmw_allreduce_i1(hecMESH, s, ntag)
subroutine hecmw_update_2_r(hecMESH, val, n)
subroutine hecmw_update_3_r(hecMESH, val, n)
subroutine hecmw_update_m_r(hecMESH, val, n, m)