22 integer(kind=kint),
parameter :: CMAT_MAX_VAL_INIT = 128
23 integer(kind=kint),
parameter :: CMAT_MAX_VAL_GROW = 2
38 if( cmat%max_val > 0 )
deallocate( cmat%pair )
52 function compair_pair_by_index( p1, p2 )
53 integer(kind=kint) :: compair_pair_by_index
56 if( p1%i < p2%i )
then
57 compair_pair_by_index = -1
58 else if( p1%i > p2%i )
then
59 compair_pair_by_index = 1
60 else if( p1%j < p2%j )
then
61 compair_pair_by_index = -1
62 else if( p1%j > p2%j )
then
63 compair_pair_by_index = 1
65 compair_pair_by_index = 0
67 end function compair_pair_by_index
69 subroutine cmat_resize( cmat, newlen )
71 integer(kind=kint) :: newlen
74 integer(kind=kint) :: i
76 if( newlen <= cmat%max_val )
return
78 if( cmat%max_val > 0 )
then
79 allocate( temp( cmat%n_val ) )
81 temp(i)%i = cmat%pair(i)%i
82 temp(i)%j = cmat%pair(i)%j
83 temp(i)%val = cmat%pair(i)%val
85 deallocate( cmat%pair )
88 allocate( cmat%pair( newlen ) )
90 if( cmat%max_val > 0 )
then
92 cmat%pair(i)%i = temp(i)%i
93 cmat%pair(i)%j = temp(i)%j
94 cmat%pair(i)%val = temp(i)%val
100 end subroutine cmat_resize
102 subroutine cmat_grow( cmat )
104 integer(kind=kint) :: newlen
106 if( cmat%max_val == 0 )
then
107 newlen = cmat_max_val_init
109 newlen = cmat%max_val * cmat_max_val_grow
111 call cmat_resize( cmat, newlen )
112 end subroutine cmat_grow
116 integer(kind=kint) :: i
117 integer(kind=kint) :: j
118 real(kind=
kreal),
dimension(:,:) :: val
119 integer(kind=kint) :: cmp
121 if( cmat%n_val == cmat%max_val )
then
122 call cmat_grow( cmat )
125 cmat%pair( cmat%n_val+1 )%i = i
126 cmat%pair( cmat%n_val+1 )%j = j
127 cmat%pair( cmat%n_val+1 )%val = val
129 if( cmat%n_val > 0 .and. cmat%sorted )
then
130 cmp = compair_pair_by_index( cmat%pair( cmat%n_val ), cmat%pair( cmat%n_val+1 ) )
132 cmat%checked = .false.
133 cmat%sorted = .false.
136 if( cmat%checked .and. cmp == 0 )
then
137 cmat%checked = .false.
141 cmat%n_val = cmat%n_val + 1
143 if( cmat%max_row < i ) cmat%max_row = i
144 if( cmat%max_col < j ) cmat%max_col = j
147 recursive subroutine sort_pair_by_index( pair, first, last )
149 integer(kind=kint) :: first
150 integer(kind=kint) :: last
151 integer(kind=kint) :: left, right
154 pivot = pair( (first + last) / 2 )
158 do while( compair_pair_by_index( pair(left), pivot ) < 0 )
161 do while( compair_pair_by_index( pivot, pair(right) ) < 0 )
164 if ( left >= right )
exit
167 pair(left) = pair(right)
173 if( first < left - 1 )
call sort_pair_by_index( pair, first, left - 1 )
174 if( right + 1 < last )
call sort_pair_by_index( pair, right + 1, last )
175 end subroutine sort_pair_by_index
179 integer(kind=kint) :: i
180 integer(kind=kint) :: n_dup, cmp
182 if( cmat%checked .or. cmat%n_val <= 1 )
return
184 if( .not. cmat%sorted )
then
185 call sort_pair_by_index( cmat%pair, 1, cmat%n_val )
191 cmp = compair_pair_by_index( cmat%pair( i-1-n_dup ), cmat%pair( i ) )
194 cmat%pair( i-n_dup )%val = cmat%pair( i-n_dup )%val + cmat%pair( i )%val
196 cmat%pair( i-n_dup )%i = cmat%pair( i )%i
197 cmat%pair( i-n_dup )%j = cmat%pair( i )%j
198 cmat%pair( i-n_dup )%val = cmat%pair( i )%val
201 cmat%n_val = cmat%n_val - n_dup
202 cmat%checked = .true.
207 real(kind=
kreal) :: x(:), y(:)
208 integer(kind=kint) :: len
209 integer(kind=kint) :: i, ii, jj, k, l
210 integer,
parameter :: ndof = 3
212 if( cmat%max_row > len .or. cmat%max_col > len )
then
213 write(*,*)
'ERROR: cmat_multvec_add: vector too short'
218 ii = ndof * (cmat%pair(i)%i - 1)
219 jj = ndof * (cmat%pair(i)%j - 1)
223 & y(ii + k) + cmat%pair(i)%val(k, l) * x(jj + l)
232 integer(kind=kint) :: inode, idof
233 real(kind=
kreal) :: rhs
234 integer(kind=kint) :: nval, i, cnode
235 integer(kind=kint),
parameter :: ndof=3
238 if( ndof < idof )
return
241 if( rhs /= 0.d0 )
then
242 do nval=1,hecmat%cmat%n_val
243 if( hecmat%cmat%pair(nval)%j /= inode ) cycle
244 cnode = hecmat%cmat%pair(nval)%i
245 if( cnode == inode )
then
248 hecmat%B(ndof*(cnode-1)+i) = hecmat%B(ndof*(cnode-1)+i) &
249 - hecmat%cmat%pair(nval)%val(i,idof)*rhs
253 hecmat%B(ndof*(cnode-1)+i) = hecmat%B(ndof*(cnode-1)+i) &
254 - hecmat%cmat%pair(nval)%val(i,idof)*rhs
261 do nval=1,hecmat%cmat%n_val
262 if( hecmat%cmat%pair(nval)%i /= inode ) cycle
264 hecmat%cmat%pair(nval)%val(idof,:)=0.d0
267 do nval=1,hecmat%cmat%n_val
268 if( hecmat%cmat%pair(nval)%j /= inode ) cycle
270 hecmat%cmat%pair(nval)%val(:,idof)=0.d0
278 integer,
intent(in) :: symm
279 integer(kind=kint) :: nval, ind, jnd, k, m, mnd
283 do nval=1,hecmat%cmat%n_val
284 ind = hecmat%cmat%pair(nval)%i
285 jnd = hecmat%cmat%pair(nval)%j
287 if( (symm==1) .and. (ind<jnd) ) cycle
291 if( ind/=k .and. jnd/=k ) cycle
292 do m= hecmat%indexL(k-1)+1, hecmat%indexL(k)
294 if( (ind==k .and. jnd==mnd) .or. (ind==mnd .and. jnd==k) )
then
308 integer(kind=kint) :: i, j, k, l, countcal, countcau
310 allocate (hecmat%indexCL(0:hecmat%NP), hecmat%indexCU(0:hecmat%NP))
316 do j= 1, hecmat%cmat%n_val
317 if (hecmat%cmat%pair(j)%i == i .and. hecmat%cmat%pair(j)%j < i)
then
318 hecmat%indexCL(i) = hecmat%indexCL(i) + 1
320 if (hecmat%cmat%pair(j)%i == i .and. hecmat%cmat%pair(j)%j > i)
then
321 hecmat%indexCU(i) = hecmat%indexCU(i) + 1
324 hecmat%indexCL(i) = hecmat%indexCL(i) + hecmat%indexCL(i-1)
325 hecmat%indexCU(i) = hecmat%indexCU(i) + hecmat%indexCU(i-1)
328 hecmat%NPCL = hecmat%indexCL(hecmat%NP)
329 hecmat%NPCU = hecmat%indexCU(hecmat%NP)
331 allocate (hecmat%itemCL(hecmat%NPCL), hecmat%itemCU(hecmat%NPCU))
332 allocate (hecmat%CAL(9*hecmat%NPCL), hecmat%CAU(9*hecmat%NPCU))
337 do j= 1, hecmat%cmat%n_val
338 if (hecmat%cmat%pair(j)%i == i .and. hecmat%cmat%pair(j)%j < i)
then
339 countcal = countcal + 1
340 hecmat%itemCL(countcal) = hecmat%cmat%pair(j)%j
343 hecmat%CAL(9*(countcal-1)+3*(k-1)+l) = hecmat%cmat%pair(j)%val(k,l)
347 if (hecmat%cmat%pair(j)%i == i .and. hecmat%cmat%pair(j)%j > i)
then
348 countcau = countcau + 1
349 hecmat%itemCU(countcau) = hecmat%cmat%pair(j)%j
352 hecmat%CAU(9*(countcau-1)+3*(k-1)+l) = hecmat%cmat%pair(j)%val(k,l)
364 deallocate (hecmat%indexCL, hecmat%itemCL, hecmat%CAL)
365 deallocate (hecmat%indexCU, hecmat%itemCU, hecmat%CAU)
372 dest%n_val = src%n_val
373 dest%max_val = src%max_val
374 if (
associated(src%pair)) dest%pair => src%pair
375 dest%checked = src%checked
376 dest%sorted = src%sorted
377 dest%max_row = src%max_row
378 dest%max_col = src%max_col
integer(kind=kint) function hecmw_comm_get_comm()
integer(kind=4), parameter kreal
subroutine hecmw_abort(comm)