FrontISTR  5.9.0
Large-scale structural analysis program with finit element method
hecmw_matrix_ordering_MC.f90
Go to the documentation of this file.
1 !-------------------------------------------------------------------------------
2 ! Copyright (c) 2019 FrontISTR Commons
3 ! This software is released under the MIT License, see LICENSE.txt
4 !-------------------------------------------------------------------------------
5 
6 module m_hecmw_matrix_ordering_mc
7  use hecmw_util
8  implicit none
9 
10  private
11  public :: hecmw_matrix_ordering_mc
12  public :: hecmw_matrix_ordering_mc_l1
13  public :: hecmw_matrix_ordering_mc_l2
14 
15 contains
16 
17  subroutine hecmw_matrix_ordering_mc(N, indexL, itemL, indexU, itemU, &
18  perm_cur, ncolor_in, ncolor_out, COLORindex, perm, iperm)
19  implicit none
20  integer(kind=kint), intent(in) :: n
21  integer(kind=kint), intent(in) :: indexl(0:), indexu(0:)
22  integer(kind=kint), intent(in) :: iteml(:), itemu(:)
23  integer(kind=kint), intent(in) :: perm_cur(:)
24  integer(kind=kint), intent(in) :: ncolor_in
25  integer(kind=kint), intent(out) :: ncolor_out
26  integer(kind=kint), intent(out) :: colorindex(0:)
27  integer(kind=kint), intent(out) :: perm(:), iperm(:)
28  integer(kind=kint), allocatable :: iwk(:)
29  integer(kind=kint) :: nn_color, cntall, cnt, color
30  integer(kind=kint) :: i, inode, j, jnode
31  allocate(iwk(n))
32 
33  iwk = 0
34  nn_color = n / ncolor_in
35  cntall = 0
36  colorindex(0) = 0
37  do color=1,n
38  cnt = 0
39  do i=1,n
40  inode = perm_cur(i)
41  if (iwk(inode) > 0 .or. iwk(inode) == -1) cycle
42  ! if (iwk(inode) == 0)
43  iwk(inode) = color
44  cntall = cntall + 1
45  perm(cntall) = inode
46  cnt = cnt + 1
47  if (cnt == nn_color) exit
48  if (cntall == n) exit
49  ! mark all connected and uncolored nodes
50  do j = indexl(inode-1)+1, indexl(inode)
51  jnode = iteml(j)
52  if (iwk(jnode) == 0) iwk(jnode) = -1
53  end do
54  do j = indexu(inode-1)+1, indexu(inode)
55  jnode = itemu(j)
56  if (jnode > n) cycle
57  if (iwk(jnode) == 0) iwk(jnode) = -1
58  end do
59  end do
60  colorindex(color) = cntall
61  if (cntall == n) then
62  ncolor_out = color
63  exit
64  end if
65  ! unmark all marked nodes
66  do i=1,n
67  if (iwk(i) == -1) iwk(i) = 0
68  end do
69  end do
70  deallocate(iwk)
71  ! make iperm
72  do i=1,n
73  iperm(perm(i)) = i
74  end do
75  end subroutine hecmw_matrix_ordering_mc
76 
77  subroutine hecmw_matrix_ordering_mc_l1(N, indexL, itemL, indexU, itemU, &
78  perm_cur, ncolor_in, ncolor_out, COLORindex, perm, iperm)
79  implicit none
80  integer(kind=kint), intent(in) :: n
81  integer(kind=kint), intent(in) :: indexl(0:), indexu(0:)
82  integer(kind=kint), intent(in) :: iteml(:), itemu(:)
83  integer(kind=kint), intent(in) :: perm_cur(:)
84  integer(kind=kint), intent(in) :: ncolor_in
85  integer(kind=kint), intent(out) :: ncolor_out
86  integer(kind=kint), intent(out) :: colorindex(0:)
87  integer(kind=kint), intent(out) :: perm(:), iperm(:)
88  integer(kind=kint), allocatable :: iwk(:)
89  integer(kind=kint) :: nn_color, cntall, cnt, color
90  integer(kind=kint) :: i, inode, j, jnode, k, knode
91  allocate(iwk(n))
92 
93  iwk = 0
94  nn_color = n / ncolor_in
95  cntall = 0
96  colorindex(0) = 0
97  do color=1,n
98  cnt = 0
99  do i=1,n
100  inode = perm_cur(i)
101  if (iwk(inode) > 0 .or. iwk(inode) == -1) cycle
102  ! if (iwk(inode) == 0)
103  iwk(inode) = color
104  cntall = cntall + 1
105  perm(cntall) = inode
106  cnt = cnt + 1
107  if (cnt == nn_color) exit
108  if (cntall == n) exit
109  ! mark all connected and uncolored nodes
110  do j = indexl(inode-1)+1, indexl(inode)
111  jnode = iteml(j)
112  if (iwk(jnode) == 0) iwk(jnode) = -1
113  do k = indexl(jnode-1)+1, indexl(jnode)
114  knode = iteml(k)
115  if (iwk(knode) == 0) iwk(knode) = -1
116  end do
117  do k = indexu(jnode-1)+1, indexu(jnode)
118  knode = itemu(k)
119  if (knode > n) cycle
120  if (iwk(knode) == 0) iwk(knode) = -1
121  end do
122  end do
123  do j = indexu(inode-1)+1, indexu(inode)
124  jnode = itemu(j)
125  if (jnode > n) cycle
126  if (iwk(jnode) == 0) iwk(jnode) = -1
127  do k = indexl(jnode-1)+1, indexl(jnode)
128  knode = iteml(k)
129  if (iwk(knode) == 0) iwk(knode) = -1
130  end do
131  do k = indexu(jnode-1)+1, indexu(jnode)
132  knode = itemu(k)
133  if (knode > n) cycle
134  if (iwk(knode) == 0) iwk(knode) = -1
135  end do
136  end do
137  end do
138  colorindex(color) = cntall
139  if (cntall == n) then
140  ncolor_out = color
141  exit
142  end if
143  ! unmark all marked nodes
144  do i=1,n
145  if (iwk(i) == -1) iwk(i) = 0
146  end do
147  end do
148  deallocate(iwk)
149  ! make iperm
150  do i=1,n
151  iperm(perm(i)) = i
152  end do
153 end subroutine hecmw_matrix_ordering_mc_l1
154 
155 subroutine hecmw_matrix_ordering_mc_l2(N, indexL, itemL, indexU, itemU, &
156  perm_cur, ncolor_in, ncolor_out, COLORindex, perm, iperm)
157 implicit none
158 integer(kind=kint), intent(in) :: n
159 integer(kind=kint), intent(in) :: indexl(0:), indexu(0:)
160 integer(kind=kint), intent(in) :: iteml(:), itemu(:)
161 integer(kind=kint), intent(in) :: perm_cur(:)
162 integer(kind=kint), intent(in) :: ncolor_in
163 integer(kind=kint), intent(out) :: ncolor_out
164 integer(kind=kint), intent(out) :: colorindex(0:)
165 integer(kind=kint), intent(out) :: perm(:), iperm(:)
166 integer(kind=kint), allocatable :: iwk(:)
167 integer(kind=kint) :: nn_color, cntall, cnt, color
168 integer(kind=kint) :: i, inode, j, jnode, k, knode, l, lnode, m, mnode
169 allocate(iwk(n))
170 
171 iwk = 0
172 nn_color = n / ncolor_in
173 cntall = 0
174 colorindex(0) = 0
175 do color=1,n
176  cnt = 0
177  do i=1,n
178  inode = perm_cur(i)
179  if (iwk(inode) > 0 .or. iwk(inode) == -1) cycle ! check
180  ! if (iwk(inode) == 0)
181  iwk(inode) = color
182  cntall = cntall + 1
183  perm(cntall) = inode
184  cnt = cnt + 1
185  if (cnt == nn_color) exit
186  if (cntall == n) exit
187  ! mark all connected and uncolored nodes
188  do j = indexl(inode-1)+1, indexl(inode)
189  jnode = iteml(j)
190  if (iwk(jnode) == 0) iwk(jnode) = -1
191  do k = indexl(jnode-1)+1, indexl(jnode)
192  knode = iteml(k)
193  if (iwk(knode) == 0) iwk(knode) = -1
194  do l = indexl(knode-1)+1, indexl(knode)
195  lnode = iteml(l)
196  if (iwk(lnode) == 0) iwk(lnode) = -1
197  end do
198  do l = indexu(knode-1)+1, indexu(knode)
199  lnode = itemu(l)
200  if (lnode > n) cycle
201  if (iwk(lnode) == 0) iwk(lnode) = -1
202  end do
203  end do
204  do k = indexu(jnode-1)+1, indexu(jnode)
205  knode = itemu(k)
206  if (knode > n) cycle
207  if (iwk(knode) == 0) iwk(knode) = -1
208  do l = indexl(knode-1)+1, indexl(knode)
209  lnode = iteml(l)
210  if (iwk(lnode) == 0) iwk(lnode) = -1
211  end do
212  do l = indexu(knode-1)+1, indexu(knode)
213  lnode = itemu(l)
214  if (lnode > n) cycle
215  if (iwk(lnode) == 0) iwk(lnode) = -1
216  end do
217  end do
218  end do
219  do j = indexu(inode-1)+1, indexu(inode)
220  jnode = itemu(j)
221  if (jnode > n) cycle
222  if (iwk(jnode) == 0) iwk(jnode) = -1
223  do k = indexl(jnode-1)+1, indexl(jnode)
224  knode = iteml(k)
225  if (iwk(knode) == 0) iwk(knode) = -1
226  do l = indexl(knode-1)+1, indexl(knode)
227  lnode = iteml(l)
228  if (iwk(lnode) == 0) iwk(lnode) = -1
229  end do
230  do l = indexu(knode-1)+1, indexu(knode)
231  lnode = itemu(l)
232  if (lnode > n) cycle
233  if (iwk(lnode) == 0) iwk(lnode) = -1
234  end do
235  end do
236  do k = indexu(jnode-1)+1, indexu(jnode)
237  knode = itemu(k)
238  if (knode > n) cycle
239  if (iwk(knode) == 0) iwk(knode) = -1
240  do l = indexl(knode-1)+1, indexl(knode)
241  lnode = iteml(l)
242  if (iwk(lnode) == 0) iwk(lnode) = -1
243  end do
244  do l = indexu(knode-1)+1, indexu(knode)
245  lnode = itemu(l)
246  if (lnode > n) cycle
247  if (iwk(lnode) == 0) iwk(lnode) = -1
248  end do
249  end do
250  end do
251  end do
252  colorindex(color) = cntall
253  if (cntall == n) then
254  ncolor_out = color
255  exit
256  end if
257  ! unmark all marked nodes
258  do i=1,n
259  if (iwk(i) == -1) iwk(i) = 0
260  end do
261 end do
262 
263 deallocate(iwk)
264 ! make iperm
265 do i=1,n
266  iperm(perm(i)) = i
267 end do
268 end subroutine hecmw_matrix_ordering_mc_l2
269 
270 end module m_hecmw_matrix_ordering_mc
hecmw_util
I/O and Utility.
Definition: hecmw_util_f.F90:7
m_hecmw_matrix_ordering_mc
Definition: hecmw_matrix_ordering_MC.f90:6
m_hecmw_matrix_ordering_mc::hecmw_matrix_ordering_mc
subroutine, public hecmw_matrix_ordering_mc(N, indexL, itemL, indexU, itemU, perm_cur, ncolor_in, ncolor_out, COLORindex, perm, iperm)
Definition: hecmw_matrix_ordering_MC.f90:19
m_hecmw_matrix_ordering_mc::hecmw_matrix_ordering_mc_l2
subroutine, public hecmw_matrix_ordering_mc_l2(N, indexL, itemL, indexU, itemU, perm_cur, ncolor_in, ncolor_out, COLORindex, perm, iperm)
Definition: hecmw_matrix_ordering_MC.f90:157
m_hecmw_matrix_ordering_mc::hecmw_matrix_ordering_mc_l1
subroutine, public hecmw_matrix_ordering_mc_l1(N, indexL, itemL, indexU, itemU, perm_cur, ncolor_in, ncolor_out, COLORindex, perm, iperm)
Definition: hecmw_matrix_ordering_MC.f90:79